glmBfp coverage - 76.24%

Files
Source

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[getFpTransforms.R] by DSB Fre 15/06/2012 16:05 (CEST)>
##
## Description:
## Transform a variable according to FP transformation formula and attach proper
## names to the resulting design matrix.
##
## History:
## 06/01/2010   copy from package bfp, slightly pimp and add Roxygen stuff
## 15/06/2012   simplify %bt% documentation for new roxygen package
#####################################################################################


##' Box Tidwell transformation
##'
##' Simple function to apply the Box Tidwell transformation to a vector, when a (single) power is
##' provided.
##'
##' @param x the numeric vector
##' @param pow the single power
##' @return the transformed vector
##'
##' @name boxTidwell
##' @aliases boxTidwell '%bt%'
##' @keywords utilities internal
"%bt%" <- function(x,
                   pow) {
  ## checks
  stopifnot(
    identical(length(pow), 1L),
    is.numeric(x),
    is.numeric(pow)
  )

  ## transformation
  if (pow != 0) {
    x^pow
  } else { ## pow == 0
    log(x)
  }
}


##' Get the FP transforms matrix of a given covariate vector
##'
##' Get the (centered) FP transforms matrix of a given covariate vector, when the corresponding
##' power vector (with at least one element) is provided.
##'
##' @param vec positive (== already shifted and scaled) column vector with proper colname
##' @param powers power vector with at least one element
##' @param center center the columns of the FP transforms matrix around zero? (default)
##' @return the FP transforms matrix with proper colnames.
##'
##' @keywords utilities internal
getFpTransforms <- function(vec,
                            powers,
                            center = TRUE) {
  ## internal helper function, only required here:
  getTransformName <- function(name, pow) {
    ## checks
    stopifnot(
      identical(length(pow), 1L),
      is.character(name)
    )

    ## create name
    if (pow != 0) {
      paste(name, pow, sep = "^")
    } else { ## pow == 0
      paste0("log(", name, ")")
    }
  }

  ## get properties of arguments
  name <- colnames(vec)
  vec <- as.vector(vec)
  len <- length(vec)
  np <- length(powers)

  ## start return matrix
  ret <- matrix(nrow = len, ncol = np)
  retColnames <- character(np)

  ## begin of recursion:

  ## start with vector of ones
  lastCol <- 1

  ## and power "log"
  lastPow <- 0

  ## invariant: already numRepPow times was this power repeated
  numRepPow <- 0L

  ## invariant: about to write ith column
  for (i in seq_along(powers)) {
    ## extract this power into "pi",
    ## check if it is the same as the last power and (afterwards) if we are *not* at the first power.
    if ((pi <- powers[i]) == lastPow && i != 1L) {
      ## repeated powers case
      numRepPow <- numRepPow + 1L

      ## so we apply the rule for repeated powers
      lastCol <- lastCol * log(vec)

      ## the name is a bit complicated
      retColnames[i] <-
        if (pi == 0) {
          ## log was repeated
          paste(getTransformName(name, 0),
            numRepPow + 1L,
            sep = "^"
          )
        } else {
          ## other power was repeated
          tmp <- paste(getTransformName(name, pi),
            getTransformName(name, 0),
            sep = "*"
          )

          if (numRepPow > 1L) {
            tmp <- paste(tmp, numRepPow, sep = "^")
          }

          tmp
        }
    } else {
      ## normal case without repeated power:

      ## vector results from Box Tidwell transform
      lastCol <- vec %bt% pi

      ## and the name is easy
      retColnames[i] <- getTransformName(name, pi)

      ## reset power invariants
      numRepPow <- 0L
      lastPow <- pi
    }

    ## write the last column
    ret[, i] <- lastCol
  }

  ## optionally center the transforms matrix
  if (isTRUE(center)) {
    ret <- scale(ret, center = TRUE, scale = FALSE)
  }

  ## attach proper colnames
  colnames(ret) <- retColnames

  ## and finally return that.
  return(ret)
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[hpds.R] by DSB Die 25/05/2010 21:32 (CEST)>
##
## Description:
## HPD functions
##
## History:
## 07/01/2010   copy + modify from package bfp
## 25/05/2010   change layout of samples argument in scrHpd
#####################################################################################

##' Construct an empirical HPD interval from samples
##'
##' Construct an empirical highest posterior density (HPD) interval from
##' samples which have been drawn from the distribution of a quantity of
##' interest.
##'
##' @param theta the vector of samples
##' @param level the credible level
##' @return  A vector with the estimated lower and upper bounds of the HPD
##' interval.
##'
##' @seealso \code{\link{scrHpd}}
##' @keywords htest
##' @export
empiricalHpd <- function(theta,
                         level) {
  ## check that theta is numeric, and that level is in (0, 1)
  stopifnot(
    is.numeric(theta),
    0 < level && 1 > level
  )

  ## how many samples are saved in theta?
  nSamples <- length(theta)

  ## get the sorted samples vector
  thetaSorted <- sort.int(theta, method = "quick")

  ## how many different credible intervals with "level"
  ## do we need to compare?
  nIntervals <- ceiling(nSamples * (1 - level))

  ## these are the start indexes of the intervals
  startIndexes <- seq_len(nIntervals)

  ## and these are the end indexes of the intervals
  endIndexes <- nSamples - nIntervals + startIndexes

  ## which interval has the smallest range?
  smallestInterval <- which.min(thetaSorted[endIndexes] - thetaSorted[startIndexes])

  ## then return the bounds of this smallest interval
  return(c(
    lower = thetaSorted[startIndexes[smallestInterval]],
    upper = thetaSorted[endIndexes[smallestInterval]]
  ))
}


##' Calculate an SCB from a samples matrix
##'
##' Calculate an SCB from a samples matrix, which minimizes
##' the absolute distances of the contained samples to a mode vector, at
##' each gridpoint. Therefore the SCB might be considered an \dQuote{HPD
##' SCB}.
##'
##' @param samples m by n matrix where m is the number of parameters,
##' n is the number of samples and  hence each (multivariate) sample is a column in
##' the matrix \code{samples}
##' @param mode mode vector of length m (defaults to the vector of medians)
##' @param level credible level for the SCB (default: 0.95)
##' @return A matrix with columns \dQuote{lower} and \dQuote{upper}, with the
##' lower and upper SCB bounds, respectively.
##'
##' @references Besag, J.; Green, P.; Higdon, D. & Mengersen, K. (1995):
##'  \dQuote{Bayesian computation and stochastic systems (with
##'   discussion)}, \emph{Statistical Science}, 10, 3-66.
##' @seealso \code{\link{empiricalHpd}}
##' @keywords htest multivariate
##' @export
scrHpd <- function(samples,
                   mode = apply(samples, 1, median),
                   level = 0.95) {
  ## extracts
  nPars <- nrow(samples) # the number of parameters
  nSamples <- ncol(samples) # the number of samples

  ## checks
  if (nPars != length(mode)) {
    stop("mode vector must have same length as samples matrix!")
  }
  stopifnot(level > 0 && level < 1)

  ## absolute distance from mode vector
  distance <- abs(sweep(samples, 1, mode))

  ## Calculate a simultaneous (k/ nSamples)*100% credible band
  ## using the ranks approach:
  k <- floor(level * nSamples)

  ## rowwise (= parameterwise) ranks of distances
  rankdistance <- apply(distance, 1, rank)

  ## maximum ranks in each multivariate sample
  tstari <- apply(rankdistance, 1, max)

  ## sort the maximum ranks
  ordtstari <- sort.int(tstari, method = "quick")

  ## the required rank, which divides the samples in contained and rejected samples for the SCB,
  ## is:
  tstar <- ordtstari[k]

  ## now which vectors are inside the SCB?
  whichInside <- tstari <= tstar
  ## note that sum(whichInside) is possibly larger than k, so we have
  ## a larger empirical coverage of the resulting SCB.

  ## reduce the samples matrix accordingly.
  samples <- samples[, whichInside]

  ## the parameterwise ranges of these vectors form the SCB
  ## (just the convex hull of all sample vectors!)
  ret <- t(apply(samples, 1, range))
  colnames(ret) <- c("lower", "upper")

  ## finally return the (nPars x 2) matrix
  return(ret)
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[glmBayesMfp.R] by DSB Mit 03/07/2013 22:57 (CEST)>
##
## Description:
## Main user interface for Bayesian inference for fractional polynomials in generalized linear
## models and Cox models.
##
## History:
## 26/10/2009   file creation: copy and modify the old BayesMfp.R
## 27/10/2009   first only allow the binomial family, and write the code in an
##              extensible way, so that it later can be extended easily when binomial works
##              (11/12/2009 note: actually we now have generality for all GLM families.)
## 06/11/2009   include group sizes
## 09/11/2009   add Gauss Hermite quantiles and weights
## 18/11/2009   progress towards first testable version of the marginal likelihood
##              approximation,
##              use roxygen after cleaning the package from old hyper-g stuff.
## 01/12/2009   do not coerce model response to type double automatically,
##              because it could be a factor in the binomial case.
## 11/12/2009   rewrite passing of info to C++ and storage of attributes info,
##              to make it clearer and facilitate reuse in other functions, e.g. sampleGlm.
## 06/01/2010   extend getFamily to return self-crafted "simulate" function in the
##              return list. This is used e.g. by "sampleGlm".
## 12/02/2010   for clarity, split off helper functions into their separate files,
##              so we need to include them in the preamble
## 17/02/2010   split off null model information computation, and include the returned
##              list in the things passed to C++ (instead of only the log marginal
##              likelihood for the null model)
## 15/03/2010   also pass weights to C++ via the family list,
##              new g-prior class is expected in the prior list
## 12/04/2010   do not coerce totalNumber to integer but to double, as it is done in C++
##              in the same manner and keeps the number space large enough.
## 14/04/2010   add "useBfgs" and "largeVariance" options.
## 17/05/2010   useBfgs=FALSE ("optimize") is now the default because it is more
##              robust than Bfgs. Add "useOpenMP" option, which makes it easier
##              to switch than setting the environment variable OMP_NUM_THREADS.
## 21/05/2010   be more careful when passing "fpnames" to C++
## 25/05/2010   add "nObs" to "data" attribute of return list.
## 08/07/2010   add an empirical Bayes option which ranks the models in terms of
##              approximate *conditional* marginal likelihoods
## 29/07/2010   add the new option to get a better Laplace approximation in the
##              case of binary logistic regression.
## 08/07/2011   add the new modelPrior option "dependent"
## 29/07/2011   now "higherOrderCorrection"
## 15/02/2012   check that not two terms contain the same covariate in
##              the formula
## 21/11/2012   add "tbf" option
## 03/12/2012   add Cox regression
## 10/12/2012   fix bug: order according to survival times when Cox model is
##              requested, otherwise the computed deviances are wrong!!
## 06/02/2013   remove default for "family"
## 03/07/2013   - add offsets
##              - remove getNullModelInfo
## 26/05/2014   Added option (useFixedc) to calculate (or not) c factor using
##              mean of observations as in null model instead of alpha=0.
#####################################################################################

##' @include helpers.R
##' @include formula.R
##' @include fpScale.R
##' @include GPrior-classes.R
##' @include getFamily.R
NULL


##' Bayesian model inference for fractional polynomial GLMs and Cox models
##'
##' Bayesian model inference for fractional polynomial models from the generalized linear model
##' family or the Cox model is conducted by means of either exhaustive model space evaluation or
##' posterior model sampling. The approach is based on analytical marginal likelihood
##' approximations, using integrated Laplace approximation. Alternatively, test-based Bayes factors
##' (TBFs) are used.
##'
##' The formula is of the form \code{y ~ bfp (x1, max = 4) + uc (x2 + x3)}, that is, the auxiliary
##' functions \code{\link{bfp}} and \code{\link{uc}} must be used for defining the fractional
##' polynomial and uncertain fixed form covariates terms, respectively. There must be an intercept,
##' and no other fixed covariates are allowed. All \code{max} arguments of the \code{\link{bfp}}
##' terms must be identical. \code{y} is the response vector for GLMs or the vector of survival
##' times for Cox regression. Note that Cox regression is only implemented with TBFs.
##'
##' The prior specifications are a list:
##' \describe{
##'   \item{gPrior}{A g-prior class object. Defaults to a hyper-g prior. See
##'   \code{\linkS4class{GPrior}} for more information.}
##'   \item{modelPrior}{choose if a flat model prior (\code{"flat"}), a
##'   model prior favoring sparse models explicitly (default, \code{"sparse"}),
##'   or a dependent model prior (\code{"dependent"}) should be used.}
##' }
##'
##' If \code{method = "ask"}, the user is prompted with the maximum cardinality of the model space
##' and can then decide whether to use posterior sampling or the exhaustive model space evaluation.
##'
##' Note that if you specify only one FP term, the exhaustive model search must be done, due to the
##' structure of the model sampling algorithm. However, in reality this will not be a problem as the
##' model space will typically be very small.
##' @param formula model formula
##' @param censInd censoring indicator. Default is \code{NULL}, but if a non-\code{NULL} vector is
##'   supplied, this is assumed to be logical (\code{TRUE} = observed, \code{FALSE} = censored) and
##'   Cox regression is performed.
##' @param data optional data.frame for model variables (defaults to the parent frame)
##' @param weights optionally a vector of positive weights (if not provided, a vector of one's)
##' @param offset this can be used to specify an _a priori_ known component to be included in the
##'   linear predictor during fitting. This must be a numeric vector of length equal to the number
##'   of cases (if not provided, a vector of zeroes)
##' @param family distribution and link (as in the glm function). Needs to be explicitly specified
##'   for all models except the Cox model.
##' @param phi value of the dispersion parameter (defaults to 1)
##' @param tbf Use TBF methodology to compute the marginal likelihood? (not default) Must be
##'   \code{TRUE} if Cox regression is done.
##' @param empiricalBayes rank the models in terms of \emph{conditional} marginal likelihood, using
##'   an empirical Bayes estimate of g? (not default) Due to coding structure, the prior on g must
##'   be given in \code{priorSpecs} although it does not have an effect when
##'   \code{empiricalBayes==TRUE}.
##' @param fixedg If this is a number, then it is taken as a fixed value of g, and as with the
##'   \code{empiricalBayes} option, the models are ranked in terms of conditional marginal
##'   likelihood. By default, this option is \code{NULL}, which means that g is estimated in a fully
##'   or empirical Bayesian way.
##' @param priorSpecs prior specifications, see details
##' @param method which method should be used to explore the  posterior model space? (default: ask
##'   the user)
##' @param subset optional subset expression
##' @param na.action default is to skip rows with missing data, and no other option supported at the
##'   moment
##' @param verbose should information on computation progress be given? (default)
##' @param debug print debugging information? (not default)
##' @param nModels how many best models should be saved? (default: 1\% of the total number of
##'   (cached) models). Must not be larger than \code{nCache} if \code{method == "sampling"}.
##' @param nCache maximum number of best models to be cached at the same time during the model
##'   sampling, only has effect if method = sampling
##' @param chainlength length of the model sampling chain (only has an effect if sampling has been
##'   chosen as method)
##' @param nGaussHermite number of quantiles used in Gauss Hermite quadrature for marginal
##'   likelihood approximation (and later in the MCMC sampler for the approximation of the marginal
##'   covariance factor density). If \code{empiricalBayes} or a fixed g is used, this option has no
##'   effect.
##' @param useBfgs Shall the BFGS algorithm be used in the internal maximization (not default)?
##'   Else, the default Brent optimize routine is used, which seems to be more robust. If
##'   \code{empiricalBayes} or a fixed g is used, this option has no effect and always the Brent
##'   optimize routine is used.
##' @param largeVariance When should the BFGS variance estimate be considered \dQuote{large}, so
##'   that a reestimation of it is computed? (Only has an effect if \code{useBfgs == TRUE}, default:
##'   100)
##' @param useOpenMP shall OpenMP be used to accelerate the computations? (default)
##' @param higherOrderCorrection should a higher-order correction of the Laplace approximation be
##'   used, which works only for canonical GLMs? (not default)
##' @param fixedcfactor If TRUE sets the c factor assuming alpha is set to 0. Otherwise take
##'   alpha=mean(y)
##' @param  empiricalgPrior If TRUE uses the the observed information matrix instead of X'X in the g
##'   prior. (Experimental)
##' @param centerX Center the data before fitting (FALSE)
##'
##' @aliases glmBayesMfp GlmBayesMfp
##' @return An object of S3 class \code{GlmBayesMfp}.
##'
##' @keywords models regression
##' @export
glmBayesMfp <- function(formula = formula(data),
                        censInd = NULL,
                        data = parent.frame(),
                        weights,
                        offset,
                        family,
                        phi = 1,
                        tbf = FALSE,
                        empiricalBayes = FALSE,
                        fixedg = NULL,
                        priorSpecs =
                          list(
                            gPrior = HypergPrior(),
                            modelPrior = "sparse"
                          ),
                        method = c("ask", "exhaustive", "sampling"),
                        subset,
                        na.action = na.omit,
                        verbose = TRUE,
                        debug = FALSE,
                        nModels,
                        nCache = 1e9,
                        chainlength = 1e4,
                        nGaussHermite = 20,
                        useBfgs = FALSE,
                        largeVariance = 100,
                        useOpenMP = TRUE,
                        higherOrderCorrection = FALSE,
                        fixedcfactor = FALSE,
                        empiricalgPrior = FALSE,
                        centerX = TRUE) {
  ## checks
  stopifnot(
    is.bool(tbf),
    is.bool(verbose),
    is.bool(debug),
    is.bool(useBfgs),
    is.bool(empiricalBayes),
    is(priorSpecs$gPrior, "GPrior"),
    is.bool(useOpenMP),
    is.bool(higherOrderCorrection),
    is.bool(empiricalgPrior)
  )

  ## see whether GLM or Cox is requested
  doGlm <- is.null(censInd)
  if (!doGlm) {
    ## and check censoring indicator vector in the Cox case.
    ## Also: we only have Cox regression with TBFs!
    stopifnot(
      is.logical(censInd),
      tbf
    )

    ## set family to Gaussian to have some pseudo values in there
    family <- gaussian
  }

  ## see whether a fixed g is requested
  useFixedg <- !is.null(fixedg)
  if (useFixedg) {
    ## then check whether it is a valid g
    ## and that there is no conflict with the empirical Bayes option
    stopifnot(
      is.numeric(fixedg),
      identical(length(fixedg), 1L),
      fixedg > 0,
      !empiricalBayes
    )
  } else {
    fixedg <- 0
  }

  ## save call for return object
  call <- match.call()
  method <- match.arg(method)

  ## check and evaluate Gauss Hermite stuff
  nGaussHermite <- as.integer(nGaussHermite)
  gaussHermite <- statmod::gauss.quad(n = nGaussHermite, kind = "hermite")

  ## evaluate family, this list then also includes the dispersion
  family <- getFamily(family, phi)

  ## get model prior choice
  priorSpecs$modelPrior <- match.arg(priorSpecs$modelPrior,
    choices = c("flat", "sparse", "dependent")
  )

  ## evaluate call for model frame building
  m <- match.call(expand.dots = FALSE)

  ## select normal parts of the call
  temp <- c("", "formula", "data", "weights", "offset", "subset", "na.action") # "" is the function name
  m <- m[match(temp, names(m), nomatch = 0)]

  ## sort formula, so that bfp comes before uc
  ## filter special parts in formula: uncertain covariates (uc) and (Bayesian) fractional polynomials (bfp)
  special <- c("uc", "bfp")

  Terms <- if (missing(data)) {
    terms(formula, special)
  } else {
    terms(formula, special, data = data)
  }

  tempVarNames <- rownames(attr(Terms, "factors"))

  ## check if intercept is present
  if (!attr(Terms, "intercept")) {
    stop(simpleError("there must be an intercept term in the model formula"))
  }

  ucTempVarNames <- sort(tempVarNames[attr(Terms, "specials")$uc])
  bfpTempVarNames <- sort(tempVarNames[attr(Terms, "specials")$bfp])
  fixTempVarNames <- sort(tempVarNames[-c(
    1,
    attr(Terms, "specials")$uc,
    attr(Terms, "specials")$bfp
  )])


  ## now sort the formula
  sortedFormula <- paste(
    deparse(Terms[[2]]),
    "~ 1 +",
    paste(c(bfpTempVarNames, ucTempVarNames, fixTempVarNames),
      collapse = "+"
    )
  )
  sortedFormula <- as.formula(sortedFormula)

  ## filter special parts in formula: uncertain covariates (uc) and (Bayesian) fractional polynomials (bfp)
  Terms <- if (missing(data)) {
    terms(sortedFormula, special)
  } else {
    terms(sortedFormula, special, data = data)
  }

  ucTermInd <- attr(Terms, "specials")$uc # special indices in original formula (beginning with 1 = response!)
  nUcGroups <- length(ucTermInd)
  bfpTermInd <- attr(Terms, "specials")$bfp
  nFps <- length(bfpTermInd)
  fixTermInd <- seq_along(tempVarNames)[-c(1, ucTermInd, bfpTermInd)] # indices of fixed terms
  nFixGroups <- length(fixTermInd)

  ## check if bfp's are present
  if (nFps == 0) {
    warning(simpleWarning("no fractional polynomial terms in formula"))
  }

  ## get vector with covariate entries
  vars <- attr(Terms, "variables") # language object
  varlist <- eval(vars, envir = data) # list
  covariates <- paste(as.list(vars)[-c(1, 2)]) # vector with covariate entries (no list or response or Intercept)

  ## remove bfp() from entries and save the inner arguments
  bfpInner <- varlist[bfpTermInd] # saved for later use
  covariates[bfpTermInd - 1] <- unlist(bfpInner) # remove bfp( ) from formula; -1 because of reponse column

  ## if ucs are present:
  if (nUcGroups) {
    ## remove uc() from entries and save the inner arguments
    ucInner <- unlist(varlist[ucTermInd])
    covariates[ucTermInd - 1] <- ucInner

    ## determine association of terms with uc groups
    ucTermLengths <- sapply(ucInner, function(oneUc) {
      length(attr(terms(as.formula(paste("~", oneUc))), "term.labels"))
    })
    ucTermLengthsCum <- c(0, cumsum(ucTermLengths - 1)) # how much longer than 1, accumulated
    ucTermList <- lapply(seq(along = ucTermInd), function(i) { # list for association uc group and assign index
      as.integer(
        ucTermInd[i] - 1 + # Starting assign index
          ucTermLengthsCum[i] + # add lengths from before
          0:(ucTermLengths[i] - 1) # range for this uc term
      )
    })
  } else {
    ucInner <- ucTermList <- NULL
  }
  ## consistency check:
  stopifnot(identical(length(ucTermList), nUcGroups))

  # if fixed variables are present
  if (nFixGroups) {
    ## remove uc() from entries and save the inner arguments
    fixInner <- fixTempVarNames
    covariates[fixTermInd - 1] <- fixInner

    ## determine association of terms with fixed groups
    fixTermLengths <- sapply(fixInner, function(oneFix) {
      length(attr(terms(as.formula(paste("~", oneFix))), "term.labels"))
    })
    fixTermLengthsCum <- c(0, cumsum(fixTermLengths - 1)) # how much longer than 1, accumulated
    fixTermList <- lapply(seq(along = fixTermInd), function(i) { # list for association uc group and assign index
      as.integer(
        fixTermInd[i] - 1 + # Starting assign index
          fixTermLengthsCum[i] + # add lengths from before
          0:(fixTermLengths[i] - 1) # range for this uc term
      )
    })
  } else {
    fixInner <- fixTermList <- NULL
  }


  ## check that not two entries are present for any covariate,
  ## i.e. the covariate names must be unique
  if (!identical(
    covariates,
    unique(covariates)
  )) {
    stop(simpleError(paste(
      "Duplicate covariates in formula:",
      paste(covariates[duplicated(covariates)],
        sep = ", "
      )
    )))
  }

  ## build new formula from the cleaned covariate entries
  newFormula <- # is saved for predict method at the end
    update(
      sortedFormula,
      paste(
        ".~ 1 +",
        paste(covariates, collapse = "+")
      ) # only update RHS
    )
  newTerms <- if (missing(data)) {
    terms(newFormula)
  } else {
    terms(newFormula, data = data)
  }

  ## build model frame
  m$formula <- newTerms
  m$scale <- m$family <- m$verbose <- NULL
  m[[1]] <- as.name("model.frame")
  m <- eval(m, sys.parent())

  ## build design matrix
  X <- model.matrix(newTerms, m)
  Xcentered <- scale(X, center = centerX, scale = FALSE)

  ## get and check weights
  weights <- as.vector(model.weights(m))
  if (is.null(weights)) {
    weights <- rep(1, nrow(X))
  }

  if (!is.null(weights) && !is.numeric(weights)) {
    stop(simpleError("'weights' must be a numeric vector"))
  }
  if (!is.null(weights) && any(weights < 0)) {
    stop(simpleError("negative weights not allowed"))
  }

  ## get response
  Y <- model.response(m)

  ## get offsets
  offset <- as.vector(model.offset(m))
  if (!is.null(offset)) {
    if (length(offset) != NROW(Y)) {
      stop(gettextf(
        "number of offsets is %d should equal %d (number of observations)",
        length(offset), NROW(Y)
      ), domain = NA)
    }
  } else {
    offset <- rep.int(0, nrow(X))
  }

  ## check length of censoring vector in the Cox case
  if (!doGlm) {
    if (inherits(attr(m, "na.action"), "omit")) {
      censInd <- censInd[-attr(m, "na.action")]
    }
    stopifnot(identical(length(censInd), length(Y)))
  }

  ## initialize (here e.g. the binomial matrix Y case is handled as in 'glm')
  init <- family$init(y = Y, weights = weights)

  Y <- init$y
  family$weights <- as.double(init$weights)
  family$offsets <- as.double(offset)
  family$dispersions <- as.double(family$phi / init$weights) # and zero weights ?!
  family$linPredStart <- as.double(init$linPredStart)

  ## which terms gave rise to which columns?
  ## (0 = intercept, 1 = first term)
  termNumbers <- attr(X, "assign")

  ## vector of length col (X) giving uc group indices or 0 (no uc)
  ## for associating uc groups with model matrix columns: ucIndices
  fixIndices <- ucIndices <- fpMaxs <- integer(length(termNumbers))

  ## list for mapping group -> columns in model matrix: ucColList
  if (nUcGroups) {
    for (i in seq(along = ucTermList)) {
      ucIndices[termNumbers %in% ucTermList[[i]]] <- i
    }

    ucColList <- lapply(seq(along = ucTermList), function(ucGroup) which(ucIndices == ucGroup))
  } else {
    ucColList <- NULL
  }

  ## list for mapping group -> columns in model matrix: fixColList
  if (nFixGroups) {
    for (i in seq(along = fixTermList)) {
      fixIndices[termNumbers %in% fixTermList[[i]]] <- i
    }

    fixColList <- lapply(seq(along = fixTermList), function(fixGroup) which(fixIndices == fixGroup))
  } else {
    fixColList <- NULL
  }


  ## vectors of length col (X) giving maximum fp degrees or 0 (no bfp)
  ## and if scaling is wanted (1) or not (0)
  ## for associating bfps with model matrix columns
  ## In addition, scale Columns or exit if non-positive values occur
  bfpInds <- bfpTermInd - 1 + attr(Terms, "intercept") # now indexing matrix column
  for (i in seq(along = bfpInner)) {
    colInd <- bfpInds[i]
    fpObj <- bfpInner[[i]]

    fpMaxs[colInd] <- attr(fpObj, "max")

    ## get scaling info
    scaleResult <- fpScale(
      c(
        attr(fpObj, "rangeVals"), # extra values not in the data
        X[, colInd]
      ), # covariate data
      scaling = attr(fpObj, "scale")
    ) # scaling wished?
    attr(bfpInner[[i]], "prescalingValues") <- scaleResult

    ## do the scaling
    X[, colInd] <- X[, colInd] + scaleResult$shift
    X[, colInd] <- X[, colInd] / scaleResult$scale

    ## check positivity
    if (min(X[, colInd]) <= 0) {
      stop(simpleError(paste("prescaling necessary for negative values in variable", fpObj)))
    }
  }

  ## check that all maximum FP degrees are equal, so that the SWITCH move
  ## in the model sampling algorithm will always be possible.
  ## This assumption could potentially be removed later on, or otherwise the "max" option in bfp()
  ## could be removed.
  if (length(unique(fpMaxs[fpMaxs != 0])) > 1L) {
    stop(simpleError("all maximum FP degrees must be identical"))
  }

  ## Check if factor variables are used in bfp
  if (any(c("logical", "factor") %in% lapply(m, class)[bfpInds])) {
    stop(simpleError("logical or factor variables cannot be fractional polynomials"))
  }


  ## check that only the intercept (one column) is a fixed term
  if (sum(!((fpMaxs | ucIndices) | fixIndices)) > 1) {
    stop(simpleError("only the intercept can be a fixed term"))
  }

  ## attach a loglik-function, which is then called from the C++ code.
  ## It gives then the loglikelihood of the mu vector of means.
  family$loglik <- function(mu) {
    return(-0.5 * sum(family$dev.resids(y = Y, mu = mu, wt = weights)) / phi)
  }
  ## note that this does not include normalizing constants of
  ## the sampling density, e.g. - 0.5 * log(2 * pi * phi) is *not*
  ## included in the Gaussian case!

  ## fit the null model
  nullModelFit <- glm(Y ~ 1,
    weights = family$weights,
    family = family$family,
    offset = family$offsets
  )
  nullModelLogMargLik <-
    if (tbf) {
      ## if we use TBF, then the log marginal likelihood is the log
      ## test-based Bayes factor of the model versus the null model. Of
      ## course the Bayes factor of the null model versus itself is 1, so
      ## the log BF is 0.
      0
    } else {
      ## compute log marginal likelihood in the null model
      ## via the Laplace approximation:
      -nullModelFit$deviance / 2 + 0.5 * log(2 * pi * vcov(nullModelFit))
    }
  nullModelDeviance <- nullModelFit$deviance

  ## compute and print cardinality of the model space to guide decision
  fpSetCards <- ifelse(fpMaxs[fpMaxs != 0] <= 3, 8, 5 + fpMaxs[fpMaxs != 0])

  # computes number of possible univariate fps (including omission)
  # given the maximum fp degree
  getNumberPossibleFps <- function(maxDegree) {
    s <- ifelse(maxDegree <= 3, 8, 5 + maxDegree) # card. of power set
    singleDegreeNumbers <- sapply(
      seq.int(from = 0, to = maxDegree),
      function(m) choose(s - 1 + m, m)
    )
    return(sum(singleDegreeNumbers))
  }
  singleNumbers <- sapply(fpMaxs, getNumberPossibleFps)
  # maximum number of possible models (+1 for model with only fixed covariates)
  totalNumber <- prod(singleNumbers) * 2^(nUcGroups) + 1

  ## process the nModels argument
  if (missing(nModels)) {
    ## then we would like to have the default number of models:
    nModels <- max(1L, floor(totalNumber / 100))
  }
  ## check nModels is at least 1
  if (nModels < 1) {
    stop(simpleError("nModels must at least be 1"))
  }


  ## decide if we are going to do model sampling or an exhaustive search
  if (identical(method, "ask")) {
    cat("The cardinality of the model space is at most ", totalNumber, ".\n", sep = "")
    decision <- substr(
      readline(paste(
        "Do you want to do a deterministic search for the best model (y)",
        "or sample from the model space (n) or abort (else) ?\n"
      )),
      1, 1
    )

    ## ensure that correct decision string has been entered, otherwise abort
    if (!decision %in% c("y", "n")) {
      cat("Aborting.\n")
      return()
    }
  } else {
    decision <- switch(method,
      exhaustive = "y",
      sampling = "n"
    )
  }
  ## and the match.arg before ensures that no further problems can occur.

  ## translate the decision to logical variable
  doSampling <- identical(decision, "n")

  ## ensure that we only do model sampling if there is more than 1 FP term in the model
  if (doSampling && identical(nFps, 1L)) {
    warning(simpleWarning(paste(
      "We need to do an exhaustive computation of all models,",
      "because there is only 1 FP term in the model!"
    )))
    doSampling <- FALSE
  }

  ## if sampling, we possibly ask for the chainlength
  if (doSampling) {
    ## get chainlength?
    if (identical(method, "ask")) {
      chainlength <- as.numeric(readline("How long do you want the Markov chain to run?\n"))
    }


    ## compute the default number of models to be saved
    if (is.null(nModels)) {
      nModels <- as.integer(max(chainlength / 100, 1L))
    } else {
      stopifnot(nModels >= 1L)
    }

    ## check the chosen cache size
    nCache <- as.integer(nCache)
    stopifnot(nCache >= nModels)

    if (verbose) {
      cat("Starting sampler...\n")
    }
  } else {
    if (verbose) {
      cat("Starting with computation of every model...\n")
    }
  }

  ## start the progress bar (is continued in the C++ code)
  if (verbose) {
    cat("0%", rep("_", 100 - 6), "100%\n", sep = "")
  }

  ## if Cox model is requested,
  ## order the data according to the survival times!
  if (!doGlm) {
    sorted <- order(Y)

    Y <- Y[sorted]
    censInd <- censInd[sorted]
    X <- X[sorted, ]
    Xcentered <- Xcentered[sorted, ]

    if (!all(sorted == seq_along(Y))) {
      warning("Input data were reordered so that the survival times are sorted")
    }
  }

  ## pack the data together
  data <- list(
    x = X, # design matrix
    xCentered = Xcentered, # centered design matrix
    y = as.double(Y), # response vector
    nObs = nrow(X), # number of observations
    censInd = as.integer(censInd)
  ) # binary censoring indicator

  ## pack the FP info things together
  fpInfos <- list(
    fpmaxs = as.integer(fpMaxs[fpMaxs != 0]), # vector of maximum fp degrees)
    fppos = as.integer(bfpInds), # vector of fp columns
    fpcards = as.integer(fpSetCards), # cardinality of corresponding power sets
    fpnames = if (nFps == 0) character(0) else unlist(bfpInner)
  ) # names of fp terms. Note that
  # it is necessary to have this if-else
  # construction (ifelse does not work,
  # because it would take the first
  # element of the length-0 vector
  # character(0), which is NA!!)



  ## pack the UC info things together
  ucInfos <- list(
    ucIndices = as.integer(ucIndices), # vector giving uncertainty custer indices
    # (column -> which group)
    ucColList = ucColList
  ) # list for group -> which columns mapping


  ## pack the UC info things together
  fixInfos <- list(
    fixIndices = as.integer(fixIndices), # vector giving fixed covaraite custer indices
    # (column -> which group)
    fixColList = fixColList
  ) # list for group -> which columns mapping



  ## pack model search configuration:
  searchConfig <- list(
    totalNumber = as.double(totalNumber), # cardinality of model space
    nModels = as.integer(nModels), # number of best
    # models returned
    empiricalBayes = empiricalBayes, # use EB for g and
    # conditional marginal likelihoods?
    useFixedg = useFixedg, # use a fixed value of g?
    useFixedc = fixedcfactor,
    doSampling = doSampling, # shall model sampling be done? If
    # false, then exhaustive search.
    chainlength = as.double(chainlength), # how many times should a jump be
    # proposed?
    nCache = nCache, # how many models to cache at the same time
    largeVariance = as.double(largeVariance), # what is a "large" variance output
    # of BFGS?
    useBfgs = useBfgs
  ) # should we use the BFGS algorithm (or
  # Brent's optimize)?

  ## pack prior and likelihood information:
  distribution <- list(
    nullModelLogMargLik = nullModelLogMargLik, # log marg lik
    # of the null model.
    nullModelDeviance = nullModelDeviance, # corresponding deviance
    doGlm = doGlm, # should we do a GLM or a Cox model search?
    tbf = tbf, # should TBF methodology be used to
    # compute Bayes factors?
    fixedg = as.double(fixedg), # the fixed value of g
    # (0 if not used)
    gPrior = priorSpecs$gPrior, # prior on the covariance
    # factor g (S4 class object)
    modelPrior = priorSpecs$modelPrior, # model prior string
    family = family, # GLM family and link,
    yMean = mean(Y), #  pass the mean, which we use when fixedc=TRUE
    empiricalgPrior = empiricalgPrior
  ) # should we use empirical g prior

  ## pack other options
  options <- list(
    verbose = verbose, # should progress be displayed?
    debug = debug, # echo debug-style messages?
    gaussHermite = gaussHermite, # nodes and weights for Gauss
    # Hermite quadratures
    useOpenMP = useOpenMP, # should we use openMP for speed up?
    higherOrderCorrection = higherOrderCorrection
  ) # should
  # the higher-order Laplace correction be used?

  ## then go C++
  Ret <- cpp_glmBayesMfp(
    data,
    fpInfos,
    ucInfos,
    fixInfos,
    searchConfig,
    distribution,
    options
  )

  ## C++ attaches the following attributes:

  ## numVisited
  ## inclusionProbs
  ## logNormConst

  ## name the inclusion probabilities
  names(attr(Ret, "inclusionProbs")) <- c(unlist(bfpInner), ucInner)

  ## name the models with the model index
  names(Ret) <- seq_along(Ret)

  ## attach additional information:

  ## information passed to C++, which is important for e.g. the function "sampleGlm"
  attr(Ret, "data") <- data
  attr(Ret, "fpInfos") <- fpInfos
  attr(Ret, "ucInfos") <- ucInfos
  attr(Ret, "fixInfos") <- fixInfos
  attr(Ret, "searchConfig") <- searchConfig
  attr(Ret, "distribution") <- distribution
  attr(Ret, "options") <- options

  ## original call and formula
  attr(Ret, "call") <- call
  attr(Ret, "formula") <- newFormula

  ## prior specs argument
  attr(Ret, "priorSpecs") <- priorSpecs


  ## list with index info
  # fixedInds <- setdiff (1:ncol (X), c (bfpInds, which (ucIndices > 0)))
  attr(Ret, "indices") <- list(
    uc = ucIndices,
    ucList = ucColList,
    bfp = bfpInds,
    fixed = fixIndices
  )


  ## names of the terms
  fixedNamesInds <- c(setdiff(2:length(varlist), unlist(attr(Terms, "specials"))), 1)

  # interceptName <- ifelse (attr (Terms, "intercept"), "(Intercept)", NULL)
  interceptName <- if (doGlm) "(Intercept)" else if (!doGlm) NULL

  attr(Ret, "termNames") <- list(
    fixed = c(interceptName, fixInner),
    bfp = unlist(bfpInner),
    uc = ucInner
  )

  ## matrix with shift/scale info, maximum degree and cardinality of powerset
  shiftScaleMaxMat <- matrix(nrow = nFps, ncol = 4)
  colnames(shiftScaleMaxMat) <- c(
    "shift", "scale", "maxDegree",
    "cardPowerset"
  )

  if (nFps > 0L) {
    shiftScaleMaxMat[, 1:2] <- matrix(
      unlist(lapply(
        bfpInner,
        attr,
        "prescalingValues"
      )),
      ncol = 2,
      byrow = TRUE
    )
    shiftScaleMaxMat[, 3] <- fpMaxs[fpMaxs != 0]
    shiftScaleMaxMat[, 4] <- fpSetCards

    rownames(shiftScaleMaxMat) <- unlist(bfpInner)
  }

  attr(Ret, "shiftScaleMax") <- shiftScaleMaxMat

  ## set class and return
  class(Ret) <- c("GlmBayesMfp", "list")
  return(Ret)
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs
##
## Time-stamp: <[getMarginalZ.R] by DSB Mon 26/08/2013 17:19 (CEST)>
##
## Description:
## Construct a (smooth) marginal z density approximation from a model
## information list
##
## History:
## 17/02/2010   split off from sampleGlm and also export the function
## 25/02/2010   Different strategy: now potentially all four methods are tried
##              for the approximation, and the user may specify the order.
##              The normal approximation is no longer a special case which issued
##              a warning; not it is just one approximation method among all.
##              First try "spline", then "logspline", because sometimes this can remedy
##              the "too close to 0" error with "spline".
## 12/04/2010   limit the computation time for pinv.new to prepare against
##              infinite loops in this function.
## 15/05/2010   implement a very robust density approximation, which is just the
##              linear interpolation of the saved points. This "linear" method
##              differs from the other methods in that it does not depend on the
##              Runuran generators.
## 17/05/2010   "linear" is now the default, because it is very robust and works
##              nicely!
## 25/05/2010   now the "logDensVals" may contain NaN's, which we do not want to
##              include in the construction of the approximation, so we discard
##              these pairs early enough.
#####################################################################################


##' Construct a (smooth) marginal z density approximation from a model
##' information list
##'
##' @param info the model information list
##' @param method method for approximating the marginal density:
##' \describe{
##' \item{linear}{Linearly interpolate the points.}
##' \item{spline}{The saved points of the unnormalized density approximation are joined
##' by a \dQuote{monotonic} spline. The density is smoothed out to zero at the
##' tails. Since the spline might be slightly negative for extreme values, the positive part
##' is returned.}
##' \item{logspline}{The saved points of the log unnormalized density approximation are joined
##' by a \dQuote{monotonic} spline, which is then exponentiated.}
##' \item{normalspline}{A \dQuote{monotonic} spline is fitted to the differences of the saved
##' log density values and the log normal approximation. The resulting spline function is
##' exponentiated and then multiplied with the normal density.}
##' \item{normal}{Just take the normal approximation.}
##' This may also be a vector with more than one method names, to select the modify the preference
##' sequence: If the first method does not work, the second is tried and so on. The normal
##' approximation always \dQuote{works} (but may give bad results).
##' }
##' @param verbose Echo the chosen method? (not default)
##' @param plot produce plots of the different approximation steps? (not default)
##' @return a list with the log of the normalized density approximation (\dQuote{logDens}) and
##' the random number generator (\dQuote{gen}).
##'
##' @export
##' @keywords internal
getMarginalZ <- function(info,
                         method =
                           c(
                             "linear", "spline", "logspline",
                             "normalspline", "normal"
                           ),
                         verbose = FALSE,
                         plot = FALSE) {
  ## get the (ordered) z
  zVals <- info$negLogUnnormZDensities$args
  zOrder <- order(zVals)
  zVals <- zVals[zOrder]

  ## the range of z
  zMin <- zVals[1L]
  zMax <- zVals[length(zVals)]

  ## get (roughly normalized) and ordered log density values
  logDensVals <- with(
    info,
    -negLogUnnormZDensities$vals - logMargLik
  )
  logDensVals <- logDensVals[zOrder]

  ## remove pairs with NaN log density values
  isNaN <- is.nan(logDensVals)

  logDensVals <- logDensVals[!isNaN]
  zVals <- zVals[!isNaN]

  ## optionally plot that
  if (plot) {
    par(mfrow = c(2, 2))
    plot(zVals,
      exp(logDensVals),
      type = "o",
      main = "roughly normalized original values"
    )
    abline(v = info$zMode)
  }

  ## the approximating normal density is:
  normalDens <- function(z, log = FALSE) {
    dnorm(
      x = z,
      mean = info$zMode,
      sd = sqrt(info$zVar),
      log = log
    )
  }

  ## show it if wished
  if (plot) {
    curve(normalDens,
      from = zMin, to = zMax,
      main = "normal approximation",
      n = 301L
    )
    abline(v = info$zMode)
  }


  ## decide on the range of the spline function
  constant <- 0.2 * (zMax - zMin)
  extendedZVals <- c(
    zMin - constant,
    zVals,
    zMax + constant
  )

  ## add zeroes to both ends of the density values
  ## to smooth out the approximation to zero.
  densVals <- c(
    0,
    exp(logDensVals),
    0
  )

  ## grid where the approximation is checked
  extendedZGrid <- seq(
    from = min(extendedZVals),
    to = max(extendedZVals),
    length = 401L
  )

  ## what are the possible methods for computing the unnormalized z density?
  possibleMethods <-
    expression(
      ## --------------------
      spline = {
        ## now compute the spline
        cubicSplineFun <- splinefun(
          x = extendedZVals,
          y = densVals,
          method = "monoH.FC"
        )

        ## so the unnormalized z density approximation is
        function(z, log = FALSE) {
          ## set everything outside the range to zero
          ## (unfortunately this is not an option for "splinefun")
          ret <- ifelse(z > min(extendedZVals) & z < max(extendedZVals),
            cubicSplineFun(z),
            0
          )

          ## take the positive part as the spline may be slightly negative
          ## at the ends
          ret <- pmax(ret, 0)

          ## exponentiate them?
          if (log) {
            return(log(ret))
          } else {
            return(ret)
          }
        }
      },
      ## --------------------
      linear = {
        ## now compute the spline
        linearSplineFun <- approxfun(
          x = extendedZVals,
          y = densVals,
          method = "linear",
          rule = 2
        ) # return 0 outside the range.

        ## so the unnormalized z density approximation is
        function(z, log = FALSE) {
          ret <- linearSplineFun(z)

          ## exponentiate them?
          if (log) {
            return(log(ret))
          } else {
            return(ret)
          }
        }
      },
      ## --------------------
      logspline = {
        ## add very small values to both ends of the log density values
        ## to smooth out the spline
        logZero <- min(logDensVals) - 1e5
        extendedLogDensVals <- c(
          logZero,
          logDensVals,
          logZero
        )

        ## now compute the spline
        cubicSplineFun <- splinefun(
          x = extendedZVals,
          y = extendedLogDensVals,
          method = "monoH.FC"
        )

        ## so the unnormalized z density approximation is
        function(z, log = FALSE) {
          ## set everything outside the range to zero
          ## (unfortunately this is not an option for "splinefun")
          logRet <- ifelse(z > min(extendedZVals) & z < max(extendedZVals),
            cubicSplineFun(z),
            logZero
          )

          ## exponentiate them?
          if (log) {
            return(logRet)
          } else {
            return(exp(logRet))
          }
        }
      },
      ## --------------------
      normalspline = {
        ## now fit the cubic spline to the differences of the log density values.
        ## In order to get smooth decrease to zero, we add zeroes to the log difference vector
        ## at both ends
        logDiffs <- c(
          0,
          logDensVals - normalDens(zVals, log = TRUE),
          0
        )

        cubicSplineFun <- splinefun(
          x = extendedZVals,
          y = logDiffs,
          method = "monoH.FC"
        )

        ## optionally plot the spline of the log differences
        if (plot) {
          curve(cubicSplineFun,
            from = min(extendedZVals), to = max(extendedZVals),
            n = 301L,
            main = "spline of log differences"
          )
          points(
            x = extendedZVals,
            y = logDiffs
          )
          abline(v = info$zMode)
        }

        ## so the unnormalized z density approximation is
        function(z, log = FALSE) {
          ## set everything outside the range to zero
          ## (unfortunately this is not an option for "splinefun")
          splineVals <- ifelse(z > min(extendedZVals) & z < max(extendedZVals),
            cubicSplineFun(z),
            0
          )

          ## the log values:
          logRet <- splineVals + normalDens(z,
            log = TRUE
          )

          ## exponentiate them?
          if (log) {
            return(logRet)
          } else {
            return(exp(logRet))
          }
        }
      },

      ## --------------------
      normal = {
        normalDens
      }
    )

  ## decide which method to try first
  firstMethods <- match.arg(method, several.ok = TRUE)

  ## so what is the sequence this time?
  methodsSequence <- c(
    firstMethods,
    setdiff(
      c("linear", "spline", "logspline", "normalspline", "normal"),
      firstMethods
    )
  )

  ## then try the possible methods in this order
  for (m in methodsSequence) {
    ## get the unnormalized pdf
    unnormZdens <- eval(possibleMethods[[m]])

    ## first check that no infinite values occur!
    if (any(!is.finite(unnormZdens(extendedZGrid)))) {
      warning(
        "Infinite values for method ", m,
        " in density approximation",
        "going to the next method"
      )

      ## if any is not finite, then go on to the next method
      next
    }

    ## then try to get the generator for that pdf
    generator <- try(getGenerator(
      method = m,
      unnormDensFun = unnormZdens,
      xVals = extendedZVals,
      unnormDensVals = densVals
    ))

    ## if this resulted in an error (computational or time-out),
    ## go on to the next method,
    ## else break
    if (!inherits(generator, "try-error")) {
      if (verbose) {
        cat("\nTaking the", m, "approximation method\n")
      }
      break
    }
  }

  ## so the normalized log density is:
  logNormZdens <- function(z) {
    unnormZdens(z, log = TRUE) - log(generator$normConst)
  }

  ## optionally plot the final normalized approximation
  if (plot) {
    plot(extendedZGrid,
      exp(logNormZdens(extendedZGrid)),
      type = "l",
      main = "final approximation"
    )
    abline(v = info$zMode)
  }

  ## return the list with the log density and the corresponding random number generator
  return(list(
    logDens = logNormZdens,
    gen = generator$generator
  ))
}


##' Internal helper function which gets the generator (and normalizing
##' constant)
##'
##' @param method the methods string
##' @param unnormDensFun the unnormalized density function
##' @param xVals the x values
##' @param unnormDensVals the unnormalized density values
##' @return a list with the elements \dQuote{generator} and \dQuote{normConst},
##' containing the generator function (with argument \code{n} for the number
##' of samples) and the normalizing constant of the density, respectively.
##'
##' @keywords internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
getGenerator <- function(method,
                         unnormDensFun,
                         xVals,
                         unnormDensVals) {
  if (method == "linear") {
    ## we can build the generator ourselves.

    ## handy abbreviations
    nPoints <- length(xVals)
    z <- xVals
    y <- unnormDensVals

    ## first calculate the cdf points
    cdf <- numeric(nPoints)
    cdf[1L] <- 0
    for (i in 2:nPoints) {
      cdf[i] <- cdf[i - 1] +
        (y[i] + y[i - 1]) / 2 * (z[i] - z[i - 1])
    }

    ## normalize
    normConst <- cdf[nPoints]
    cdf <- cdf / normConst
    y <- y / normConst

    ## and now the corresponding inverse cdf (quantile function)
    quantFun <- function(p) {
      ## check argument
      stopifnot(
        0 <= p,
        1 >= p
      )

      ## check the boundary cases
      if (p == 0) {
        return(z[1])
      }
      if (p == 1) {
        return(z[nPoints])
      }

      ## so now we are inside.

      ## find the right interval
      i <- 2L # we can start at 2
      while (p > cdf[i]) {
        i <- i + 1L
      }
      ## so now cdf[i - 1] < p <= cdf[i]

      slope <- (y[i] - y[i - 1L]) / (z[i] - z[i - 1L])
      intercept <- y[i - 1L]
      const <- cdf[i - 1] - p

      solution <- (sqrt(intercept^2 - 2 * slope * const) - intercept) / slope

      return(solution + z[i - 1L])
    }

    ## vectorize that
    quantFunVec <- Vectorize(quantFun)

    ## so our generator function is
    gen <- function(n = 1) {
      return(quantFunVec(runif(n = n)))
    }

    ## so we return this list:
    return(list(
      generator = gen,
      normConst = normConst
    ))
  } else {
    ## some Runuran generator is built.

    ## the creation is somewhat slow,
    ## but the generation from it is very fast.

    ## However, sometimes pinv.new seems to get stuck in an
    ## infinite loop. Therefore we limit the computation time
    ## for this call (only).
    setTimeLimit(cpu = 40) # set time limit
    on.exit(setTimeLimit(cpu = Inf)) # delete time limit after exiting this
    # function. (either after normal exit or
    # after an error)

    unuranObject <- pinv.new(
      pdf = unnormDensFun,
      lb = min(xVals),
      ub = max(xVals),
      center = xVals[which.max(unnormDensVals)]
    )

    ## get the normalizing constant
    ## (this is only possible *before* the object is packed!)
    normConst <- unuran.details(unuranObject, show = FALSE, return.list = TRUE)$area.pdf

    ## "pack" the object so that it can be saved just as a normal R object.
    unuran.packed(unuranObject) <- TRUE

    ## this function returns random variates from the pdf, where n is the number of variates to be
    ## produced
    gen <- function(n = 1) {
      return(ur(unuranObject, n = n))
    }

    ## so we return this list:
    return(list(
      generator = gen,
      normConst = normConst
    ))
  }
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs.
##
## Time-stamp: <[GPrior-classes.R] by DSB Mon 26/08/2013 11:34 (CEST)>
##
## Description:
## Hopefully a clean class system for the different priors on g.
##
## History:
## 15/03/2010   file creation in response to the redesign of the C++ side.
## 23/07/2010   we now only warn instead of producing an error when the integral
##              is not equal to 1.
## 22/11/2012   add incomplete inverse gamma prior class
## 26/08/2013   link IncInvGammaGPrior from the virtual g-prior class
#####################################################################################

## ----------------------------------------------------------------------------

##' The virtual g-prior class
##'
##' This is the virtual g-prior class from which other g-prior classes derive.
##' The slots are:
##' \describe{
##' \item{logDens}{the prior log density}
##' }
##'
##' @seealso \code{\linkS4class{HypergPrior}}, \code{\linkS4class{InvGammaGPrior}},
##' \code{\linkS4class{IncInvGammaGPrior}}, \code{\linkS4class{CustomGPrior}}
##'
##' @name GPrior-class
##' @keywords classes internal
setClass(
  Class = "GPrior",
  representation =
    representation(logDens = "function"),
  contains = list("VIRTUAL"),
  validity =
    function(object) {
      ## check that the exp of the log density function
      ## is a valid density function

      XMIN <- .Machine$double.xmin
      EPS <- sqrt(.Machine$double.eps)

      integrand <- function(g) exp(object@logDens(g))
      integral <- integrate(
        f = integrand,
        lower = XMIN,
        upper = Inf
      )

      if (integral$message != "OK") {
        return(integral$message)
      } else {
        if (abs(integral$value - 1) > EPS) {
          warning(
            "density must be proper and normalized: (numerical) integral is ",
            integral$value
          )
        }

        return(TRUE)
      }
    }
)

## ----------------------------------------------------------------------------

##' The hyper-g prior class
##'
##' The slots are:
##' \describe{
##' \item{a}{the hyperparameter}
##' }
##'
##' @seealso the constructor \code{\link{HypergPrior}}
##'
##' @name HypergPrior-class
##' @keywords classes
##' @export
setClass(
  Class = "HypergPrior",
  representation =
    representation(a = "numeric"),
  contains = list("GPrior"),
  validity =
    function(object) {
      if (object@a <= 3) {
        return("the parameter a must be larger than 3 for proper posteriors")
      } else {
        return(TRUE)
      }
    }
)


##' Initialization method for the "HypergPrior" class
##'
##' @usage \S4method{initialize}{HypergPrior}(.Object, a, \dots)
##' @param .Object the \code{\linkS4class{HypergPrior}} we want to initialize
##' @param a the hyperparameter value
##' @param \dots unused
##' @return the initialized object
##'
##' @name HypergPrior-initialize
##' @aliases HypergPrior-initialize initialize,HypergPrior-method
##'
##' @keywords methods internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
##'
##' @importFrom methods callNextMethod
##'
setMethod(
  "initialize",
  signature(.Object = "HypergPrior"),
  function(.Object, a, ...) {
    .Object@logDens <- function(g) {
      return(log(a - 2) - log(2) - a / 2 * log1p(g))
    }
    callNextMethod(.Object, a = a, ...)
  }
)


##' Constructor for the hyper-g prior class
##'
##' @param a the hyperparameter which must be larger than 3, and should not be larger than 4
##' in order not to favor too much shrinkage a priori (default: 4)
##' @return a new \code{\linkS4class{HypergPrior}} object
##'
##' @keywords classes
##' @export
HypergPrior <- function(a = 4) {
  return(new("HypergPrior",
    a = a
  ))
}


## ----------------------------------------------------------------------------

##' The inverse gamma g-prior class
##'
##' The slots are:
##' \describe{
##' \item{a}{the first hyperparameter}
##' \item{b}{the second hyperparameter}
##' }
##'
##' @seealso the constructor \code{\link{InvGammaGPrior}}
##'
##' @name InvGammaGPrior-class
##' @keywords classes
##' @export
setClass(
  Class = "InvGammaGPrior",
  representation =
    representation(
      a = "numeric",
      b = "numeric"
    ),
  contains = list("GPrior"),
  validity =
    function(object) {
      if ((object@a <= 0) || (object@b <= 0)) {
        return("the parameters a and b must be positive")
      } else {
        return(TRUE)
      }
    }
)

##' Initialization method for the "InvGammaGPrior" class
##'
##' @usage \S4method{initialize}{InvGammaGPrior}(.Object, a, b, \dots)
##' @param .Object the \code{\linkS4class{InvGammaGPrior}} we want to initialize
##' @param a the first hyperparameter value
##' @param b the second hyperparameter value
##' @param \dots unused
##' @return the initialized object
##'
##' @name InvGammaGPrior-initialize
##' @aliases InvGammaGPrior-initialize initialize,InvGammaGPrior-method
##'
##' @keywords methods internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
setMethod(
  "initialize",
  signature(.Object = "InvGammaGPrior"),
  function(.Object, a, b, ...) {
    .Object@logDens <- function(g) {
      return(-(a + 1) * log(g) - b / g + a * log(b) - lgamma(a))
    }
    callNextMethod(.Object, a = a, b = b, ...)
  }
)

##' Constructor for the inverse gamma g-prior class
##'
##' @param a the first positive hyperparameter (default: 0.001)
##' @param b the second positive hyperparameter (default: 0.001)
##' @return a new \code{\linkS4class{InvGammaGPrior}} object
##'
##' @keywords classes
##' @export
InvGammaGPrior <- function(a = 0.001, b = 0.001) {
  return(new("InvGammaGPrior",
    a = a,
    b = b
  ))
}


## ----------------------------------------------------------------------------

##' The incomplete inverse gamma g-prior class
##'
##' The slots are:
##' \describe{
##' \item{a}{the first hyperparameter}
##' \item{b}{the second hyperparameter}
##' }
##'
##' @seealso the constructor \code{\link{IncInvGammaGPrior}}
##'
##' @name IncInvGammaGPrior-class
##' @keywords classes
##' @export
setClass(
  Class = "IncInvGammaGPrior",
  representation =
    representation(
      a = "numeric",
      b = "numeric"
    ),
  contains = list("GPrior"),
  validity =
    function(object) {
      if (object@a <= 0) {
        return("the parameter a must be positive")
      } else if (object@b < 0) {
        return("the parameter b must be non-negative")
      } else {
        return(TRUE)
      }
    }
)

##' Initialization method for the "IncInvGammaGPrior" class
##'
##' @usage \S4method{initialize}{IncInvGammaGPrior}(.Object, a, b, \dots)
##' @param .Object the \code{\linkS4class{IncInvGammaGPrior}} we want to initialize
##' @param a the first hyperparameter value
##' @param b the second hyperparameter value
##' @param \dots unused
##' @return the initialized object
##'
##' @name IncInvGammaGPrior-initialize
##' @aliases IncInvGammaGPrior-initialize initialize,IncInvGammaGPrior-method
##'
##' @keywords methods internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
setMethod(
  "initialize",
  signature(.Object = "IncInvGammaGPrior"),
  function(.Object, a, b, ...) {
    .Object@logDens <- function(g) {
      normConst <-
        if (b > 0) {
          a * log(b) - pgamma(b, a, log.p = TRUE) - lgamma(a)
        } else {
          log(a)
        }

      return(-(a + 1) * log1p(g) - b / (g + 1) + normConst)
    }
    callNextMethod(.Object, a = a, b = b, ...)
  }
)

##' Constructor for the incomplete inverse gamma g-prior class
##'
##' @param a the first positive hyperparameter (default: 0.001)
##' @param b the second positive hyperparameter (default: 0.001)
##' @return a new \code{\linkS4class{IncInvGammaGPrior}} object
##'
##' @keywords classes
##' @export
IncInvGammaGPrior <- function(a = 0.001, b = 0.001) {
  return(new("IncInvGammaGPrior",
    a = a,
    b = b
  ))
}


## ----------------------------------------------------------------------------

##' The custom g-prior class
##'
##' This class wraps around a custom log prior density for the covariance factor g.
##'
##' @seealso the constructor \code{\link{CustomGPrior}}
##'
##' @name CustomGPrior-class
##' @keywords classes
##' @export
setClass(
  Class = "CustomGPrior",
  contains = list("GPrior")
)


##' Constructor for the custom g-prior class
##'
##' @param logDens the log prior density function for g
##' @return a new \code{\linkS4class{CustomGPrior}} object
##'
##' @keywords classes
##' @export
CustomGPrior <- function(logDens) {
  return(new("CustomGPrior",
    logDens = logDens
  ))
}

## ----------------------------------------------------------------------------

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs
##
## Time-stamp: <[getLogGPrior.R] by DSB Mit 17/02/2010 15:55 (CET)>
##
## Description:
## Helper for glmBayesMfp which returns the normalized log g prior density.
##
## History:
## 12/02/2010   split from glmBayesMfp.R file
## 17/02/2010   reduce the lower bound for the integration to the smallest
##              value greater than zero instead of the machine epsilon, and compare the
##              difference to 1 with machine epsilon instead of the absolute error
##              (this is necessary e.g. for IG(0.001, 0.001))
#####################################################################################

##' Helper function for glmBayesMfp: Returns the normalized log g prior density
##'
##' Returns the normalized log of the prior density on g as an R function.
##' It is checked that the result is valid, that is that exp(f) integrates to 1 over the
##' positive real line.
##'
##' @param gPrior the gPrior argument passed to \code{\link{glmBayesMfp}}
##'
##' @return The R function.
##'
##' @keywords internal
getLogGPrior <- function(gPrior) {
  ## get g prior choice
  if (isTRUE(is.character(gPrior))) {
    ## which of the choices has been selected by the user?
    gPrior <- match.arg(gPrior,
      choices = ("hyperg")
    )

    ## hyper-g prior with a = 4
    gPrior <-
      if (gPrior == "hyperg") {
        function(g) -2 * log1p(g)
      }
  }

  ## check that the exp of the function it is a valid density function
  if (isTRUE(is.function(gPrior))) {
    XMIN <- .Machine$double.xmin
    EPS <- sqrt(.Machine$double.eps)

    integrand <- function(g) exp(gPrior(g))

    integral <- integrate(
      f = integrand,
      lower = XMIN,
      upper = Inf
    )

    if (integral$message != "OK") {
      stop(simpleError(integral$message))
    }
    if (abs(integral$value - 1) > EPS) {
      stop(simpleError("the g-prior density must be proper and normalized"))
    }
  } else {
    stop(simpleError("the g-prior argument must either be a valid string or a (vectorized) density function"))
  }

  ## return the function
  return(gPrior)
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[GlmBayesMfp-methods.R] by DSB Fre 07/12/2012 11:10 (CET)>
##
## Description:
## Additional convenience methods for GlmBayesMfp class objects.
##
## History:
## 12/02/2010   modify from bfp package
## 15/03/2010   adapt print.GlmBayesMfp to new S4 gPrior element
## 07/12/2012   change default for freq in as.data.frame.GlmBayesMfp
#####################################################################################

##' @include posteriors.R
NULL

##' Extract method for GlmBayesMfp objects
##'
##' Extract a subset of models from a \code{\link{GlmBayesMfp}} object.
##'
##'
##' @method [ GlmBayesMfp
##' @param x valid \code{\link{GlmBayesMfp}} object
##' @param \dots transports the indexes of the models
##' @return The subsetted object.
##' @export
##'
##' @name Extract.GlmBayesMfp
##' @aliases Extract.GlmBayesMfp [.GlmBayesMfp
##' @keywords methods
##' @seealso \code{\link{glmBayesMfp}}
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
"[.GlmBayesMfp" <- function(x, ...) {
  y <- NextMethod("[")
  mostattributes(y) <- attributes(x)
  names(y) <- names(x)[...]
  class(y) <- oldClass(x)
  y
}



##' Print a GlmBayesMfp object.
##'
##'
##' @method print GlmBayesMfp
##' @param x valid \code{\link{GlmBayesMfp}} object
##' @param \dots unused
##' @return Only used for its side effect
##'
##' @export
##'
##' @keywords methods
##' @seealso \code{\link{glmBayesMfp}}
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
print.GlmBayesMfp <- function(x, ...) {
  cat("------------------------------ GlmBayesMfp-Output ------------------------------\n")
  cat(
    length(x), "multivariable fractional polynomial model(s) of total (visited/cached)",
    attr(x, "numVisited"), "for following covariates:\n\n"
  )
  cat("fixed:                ", paste(attr(x, "termNames")$fixed, collapse = ", "), "\n")
  cat("uncertain fixed form: ", paste(attr(x, "termNames")$uc, collapse = ", "), "\n")
  cat("fractional polynomial:", paste(attr(x, "termNames")$bfp, collapse = ", "), "\n")
  pr <- attr(x, "priorSpecs")
  cat(
    "\nPrior for g was,", class(pr$gPrior),
    "\nand a ", pr$modelPrior, " prior on the model space was used.",
    "\n"
  )
}


##' Convert a GlmBayesMfp object into a data frame
##'
##'
##' @method as.data.frame GlmBayesMfp
##' @param x valid \code{\link{GlmBayesMfp}} object
##' @param row.names optional rownames (default is to keep the names of the
##' \code{\link{GlmBayesMfp}} list)
##' @param \dots unused
##' @param freq should empirical frequencies of the models in the sampling
##' path be given? (not default)
##' @return The data frame with the following columns:
##' \describe{
##'     \item{posterior}{the posterior model probabilities}
##'     \item{logMargLik}{the log marginal likelihood of the models}
##'     \item{logPrior}{the log prior probabilities of the models}
##' }
##' Additionally, for each uncertain fixed form covariates a column with the inclusion
##' status, and for each fractional polynomial a column with the powers are returned.
##' @seealso \code{\link{glmBayesMfp}}
##' @keywords methods
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
##'
##' @export
as.data.frame.GlmBayesMfp <- function(x,
                                      row.names = NULL,
                                      ...,
                                      freq = FALSE) {
  ## posterior probabilities:
  ret <- data.frame(
    posterior = posteriors(x, type = "normalized")
  )
  if (!is.null(attr(x, "searchConfig")$chainlength) && freq) {
    ret$frequency <- posteriors(x, type = "sampling")
  }

  ## row names
  row.names(ret) <-
    if (!is.null(row.names)) {
      row.names
    } else {
      names(x)
    }

  ## log marginal likelihood and log prior
  ret$logMargLik <- logMargLiks(x)
  ret$logPrior <- logPriors(x)

  ## fixed form covariates:
  for (i in seq_along(fixNames <- attr(x, "termNames")$fixed[-1])) {
    ret[[fixNames[i]]] <- sapply(
      x,
      function(one) i %in% one$configuration$fixTerms
    )
  }

  ## uncertain fixed form covariates:
  for (i in seq_along(ucNames <- attr(x, "termNames")$uc)) {
    ret[[ucNames[i]]] <- sapply(
      x,
      function(one) i %in% one$configuration$ucTerms
    )
  }
  ## fractional polynomial:
  for (fpName in attr(x, "termNames")$bfp) {
    ret[[fpName]] <- sapply(
      x,
      function(one) paste(one$configuration$powers[[fpName]], collapse = ", ")
    )
  }

  ret
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[sampleBma.R] by DSB Die 04/12/2012 09:29 (CET)>
##
## Description:
## Produce posterior samples from the Bayesian model average over models
## returned by glmBayesMfp, using MCMC.
##
## History:
## 21/05/2010   file creation.
## 24/05/2010   first implementation (without testing)
## 25/05/2010   Do not return modelFreqs;
##              return a list with element "samples" from the S4 class
##              "GlmBayesMfpSamples".
##              test the first implementation.
## 28/05/2010   rename "response" to "fitted", which shall contain the
##              *linear predictors* for the fitted data (and not the *means*).
## 26/07/2010   insert many drop=FALSE statements in matrix subsetting
## 03/08/2010   there are always z samples (even in the null model), so we do
##              need to catch special cases.
## 26/11/2012   modifications to accommodate the TBF methodology
## 04/12/2012   modifications to accommodate the Cox models
#####################################################################################

##' @include GlmBayesMfp-methods.R
##' @include helpers.R
##' @include McmcOptions-class.R
##' @include McmcOptions-methods.R
##' @include sampleGlm.R
NULL

##' Produce posterior samples from a Bayesian model average over GLMs / Cox
##' models
##'
##' Based on the result list from \code{\link{glmBayesMfp}}, sample from the
##' Bayesian model average (BMA) over the models contained in this list.
##'
##' If TBF methodology is used (which is specified within the \code{glmBayesMfp}
##' object), then Monte Carlo (MC) sampling is used. If the fully Bayesian,
##' generalized hyper-g prior methodology is used, then the sampling is based on
##' MCMC. Therefore, instead of only specifying the required number of samples
##' and the model probabilities, one also needs to specify the burn-in length
##' and the thinning parameter, which will be applied to every model from which
##' at least one sample is included in the average. Alternatively, you can ask
##' for MCMC marginal likelihood estimates for all models in the list. Then at
##' least \code{nMargLikSamples} will be produced for each model, whether
##' included in the BMA sample or not.
##'
##' @param object valid \code{GlmBayesMfp} object containing the models over
##' which to average
##' @param mcmc MCMC options object with class \code{\linkS4class{McmcOptions}},
##' specifying the number of required BMA samples (via \code{sampleSize(mcmc)}),
##' and the burn-in and thinning parameters applied to each model (see above).
##' If TBF is used, each sample is accepted, and the number of samples is given
##' by \code{\link{sampleSize}}(\code{mcmc}).
##' @param postProbs vector of posterior probabilities (will be normalized within
##' the function) for the weighting of the models in \code{object} (defaults to
##' the normalized posterior probabilities)
##' @param nMargLikSamples If this is non-\code{NULL}, it specified the number
##' of samples used for the marginal likelihood estimate for each model (see
##' above).
##' @param verbose should information on computation progress be given?
##' (default)
##' @param \dots optional further arguments already available for sampling from
##' a single model: \code{gridList}, \code{gridSize}, \code{newdata},
##' \code{weights}, \code{marginalZApprox}, \code{debug}, \code{useOpenMP}.
##' See \code{\link{sampleGlm}} for the meanings.
##'
##' @return The result is a list with the following elements:
##' \describe{
##' \item{modelData}{data frame containing the result from the
##' \code{as.data.frame} function, and in addition BMA probabilities,
##' BMA frequencies in the sample, acceptance ratios of the MCMC
##' runs and optionally marginal likelihood estimates / standard
##' errors.}
##' \item{samples}{an object of S4 class \code{\linkS4class{GlmBayesMfpSamples}}
##' containing the samples from the BMA.}
##' }
##'
##' @keywords models regression
##' @export
sampleBma <-
  function(object,
           mcmc = McmcOptions(),
           postProbs = posteriors(object),
           nMargLikSamples = NULL,
           verbose = TRUE,
           ...) {
    ## Checks
    ## **************************************************

    ## check the object
    if (!inherits(object, "GlmBayesMfp")) {
      stop(simpleError("object must be of class GlmBayesMfp"))
    }

    nModels <- length(object)
    if (!(nModels >= 1L)) {
      stop(simpleError("there has to be at least one model in the object"))
    }

    ## get attributes
    attrs <- attributes(object)

    ## check whether tbf is used
    tbf <- attrs$distribution$tbf

    ## is this a GLM or a Cox model?
    doGlm <- attrs$distribution$doGlm

    ## shall we do marginal likelihood estimations?
    estimateMargLik <- (!tbf) && (!is.null(nMargLikSamples))
    if (estimateMargLik) {
      ## then check if everything is OK
      stopifnot(
        is.numeric(nMargLikSamples),
        nMargLikSamples > 100
      )
      nMargLikSamples <- as.integer(nMargLikSamples)
    }

    ## other checks
    stopifnot(
      is.bool(verbose),
      is(mcmc, "McmcOptions"),
      identical(
        nModels,
        length(postProbs)
      ),
      postProbs >= 0
    )

    ## correct MCMC option
    if (tbf) {
      mcmc <- McmcOptions(
        burnin = 0L,
        step = 1L,
        samples = sampleSize(mcmc)
      )
    }

    ## Start samples containers
    ## **************************************************

    ## "matrices"
    fitted <- matrix(
      nrow = attrs$data$nObs,
      ncol = 0L
    )

    ## we cannot give here the right number of rows,
    ## so use NULL to which we can cbind anything
    predictions <- NULL

    ## vectors
    z <- numeric()

    ## lists
    bfpCurves <-
      fixCoefs <-
      ucCoefs <- list()

    ## Distribute samples to models
    ## **************************************************

    ## determine the sample size
    nSamples <- sampleSize(mcmc)

    ## determine the model names and the normalized weights
    objNames <- as.numeric(names(object))
    postProbs <- postProbs / sum(postProbs)

    ## be sure that at least one model has positive weight
    stopifnot(any(postProbs > 0))

    ## draw model names
    modelFreqs <-
      if (identical(length(objNames), 1L)) {
        # if there is only one model ...
        rep(objNames, nSamples)
      } else {
        # else more than one model ...
        sample(
          objNames,
          size = nSamples,
          replace = TRUE,
          prob = postProbs
        )
      }
    modelFreqs <- table(modelFreqs)
    nams <- names(modelFreqs)

    ## save model summary
    modelData <- as.data.frame(object)
    modelData[, c("bmaProb", "bmaFreq")] <- 0
    modelData[, "bmaProb"] <- postProbs
    modelData[nams, "bmaFreq"] <- modelFreqs / nSamples

    ## prepare for acceptance rates
    modelData[, "acceptanceRatio"] <- 0

    ## prepare for marginal likelihood estimates
    if (estimateMargLik) {
      modelData[, c("margLikEstimate", "margLikError")] <- 0
    }

    ## Start sampling
    ## **************************************************

    ## echo sampling start
    if (verbose) {
      cat("\nStarting sampling ...")
    }

    ## now sample from each model as often as indicated by the modelFreqs
    ## and save samples from it

    ## process every model in object
    for (j in seq_along(object)) {
      if (verbose) {
        cat("\nNow at model ", j, "...")
      }

      ## get this model
      thisModel <- object[j]
      modName <- names(thisModel)

      ## determine if this model's samples are in BMA samples
      inBma <- modName %in% nams

      ## determine the number of samples we need from this model
      thisSampleSize <-
        if (inBma) {
          ## if it is in the BMA, be sure that we have at least
          ## nMargLikSamples samples (if this is NULL, it counts as 0)
          max(
            modelFreqs[modName],
            nMargLikSamples
          )
        } else {
          ## else we only sample if we want marginal likelihood estimates
          max(
            nMargLikSamples,
            0L
          )
        }

      ## decide if we need samples from this model
      if (thisSampleSize > 0L) {
        ## Sample from this model
        ## **************************************************

        ## adapt Mcmc object to reflect the correct number of samples
        thisMcmc <- McmcOptions(
          samples = thisSampleSize,
          burnin = mcmc@burnin,
          step = mcmc@step
        )

        ## and run the sampleGlm function
        thisOut <- sampleGlm(
          object = thisModel,
          mcmc = thisMcmc,
          estimateMargLik = estimateMargLik,
          verbose = verbose, # pass the verbose option
          # from this function
          ...
        ) # and be sure to pass all other
        # options


        ## Save results
        ## **************************************************

        ## which samples do we keep from this model?
        keepSamples <-
          if (inBma) {
            ## the last modelFreqs[modName] samples
            seq(
              from = thisSampleSize - modelFreqs[modName] + 1L,
              to = thisSampleSize
            )
          } else {
            ## none
            integer()
          }

        ## save acceptance ratio
        modelData[modName, "acceptanceRatio"] <-
          thisOut$acceptanceRatio

        ## save the marginal likelihood estimates, if required
        if (estimateMargLik) {
          modelData[modName, c("margLikEstimate", "margLikError")] <-
            unlist(thisOut$logMargLik[c("estimate", "standardError")])
        }

        ## save the predictive samples, if there are any
        if (nrow(thisOut$samples@predictions) > 0L) {
          predictions <- cbind(
            predictions,
            thisOut$samples@predictions[, keepSamples, drop = FALSE]
          )
        }

        ## save z samples
        z <- c(
          z,
          thisOut$samples@z[keepSamples]
        )

        ## save all fixed coefs samples
        for (fixName in names(thisOut$samples@fixCoefs)) {
          ## get these samples
          thisFixSamples <- thisOut$samples@fixCoefs[[fixName]]

          ## append these samples
          fixCoefs[[fixName]] <-
            cbind(
              fixCoefs[[fixName]],
              thisFixSamples[, keepSamples, drop = FALSE]
            )
        }




        ## save the fit samples on the linear predictor scale
        fitted <- cbind(
          fitted,
          thisOut$samples@fitted[, keepSamples, drop = FALSE]
        )

        ## save all bfp curve samples
        for (bfpName in names(thisOut$samples@bfpCurves)) {
          ## get these samples
          thisBfpSamples <- thisOut$samples@bfpCurves[[bfpName]]

          ## append these samples
          bfpCurves[[bfpName]] <-
            cbind(
              bfpCurves[[bfpName]],
              thisBfpSamples[, keepSamples, drop = FALSE]
            )

          ## copy the grid attributes
          ## (actually we would not need to copy them every time)
          attr(bfpCurves[[bfpName]], "scaledGrid") <-
            attr(thisBfpSamples, "scaledGrid")
          attr(bfpCurves[[bfpName]], "whereObsVals") <-
            attr(thisBfpSamples, "whereObsVals")
        }

        ## save all uc coefs samples
        for (ucName in names(thisOut$samples@ucCoefs)) {
          ## get these samples
          thisUcSamples <- thisOut$samples@ucCoefs[[ucName]]

          ## append these samples
          ucCoefs[[ucName]] <-
            cbind(
              ucCoefs[[ucName]],
              thisUcSamples[, keepSamples, drop = FALSE]
            )
        }
      }
    }

    ## Collect things in return list
    ## **************************************************

    ## be sure that predictions is a matrix, even if we have no
    ## predictive samples
    predictions <-
      if (is.null(predictions)) {
        matrix(nrow = 0, ncol = 0)
      } else {
        predictions
      }

    ret <- list(
      modelData = modelData,
      samples =
        new(
          "GlmBayesMfpSamples",
          fitted = fitted,
          predictions = predictions,
          fixCoefs = fixCoefs,
          z = z,
          bfpCurves = bfpCurves,
          ucCoefs = ucCoefs,
          shiftScaleMax = attrs$shiftScaleMax,
          nSamples = nSamples
        )
    )


    ## finally return the whole stuff.
    return(ret)
  }

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Description:
## Friendlier interface to fit Cox models with glmBayesMfp
##
## History:
## 14/07/2015 Copy from CoxTBFs project
#####################################################################################

##' @include helpers.R
##' @include getDesignMatrix.R
NULL


##' Fit Cox models using glmBayesMfp
##'
##' A simplified formula based interface to \code{\link{glmBayesMfp}} to fit Cox models. Can return
##' Maximum a posteriori (MAP) model, Median probability model (MPM) or Bayesian model average
##' (BMA). Provides global empirical Bayes and AIC/BIC based model inference.
##'
##' @param formula model formula with Surv object as LHS and \code{\link{uc}} or \code{\link{bfp}}
##'   variables as RHS.
##' @param data data.frame for model variables
##' @param type type of model to fit, one of "MAP","MPM","BMA","BMAFull"
##' @param baseline how to calculate the baseline hazard function. "cox" uses unshrunken
##'   coefficients. "shrunk" refits baseline with shrunken coefficients (default).
##' @param globalEB use global empirical bayes estimate of g (default=FALSE)
##' @param IC use information criteria based model selection (default=FALSE). Either "AIC" or "BIC".
##' @param sep estimate baseline hazard for each estimate of model coefficients (default=FALSE).
##' @param keepModelList keep the model list returned by glmBayesMfp for MAP and MPM models
##'   (default=FALSE).
##' @param ... additional arguments to pass to \code{\link{glmBayesMfp}}
##' @param overrideConfig replaces the the MAP model with the given configuration, which is passed
##'   to \code{\link{computeModels}}
##'
##' @return An object of S3 class \code{TBFcox} or \code{TBFcox.sep} if sep=TRUE.
##'
##' @keywords models regression
##'
##' @import stats
##' @export
coxTBF <- function(formula,
                   data,
                   type = "MAP",
                   baseline = "shrunk",
                   globalEB = FALSE,
                   IC = FALSE,
                   sep = FALSE,
                   keepModelList = FALSE,
                   ...,
                   overrideConfig) {
  formula <- as.formula(formula)

  LHS <- formula[[2]][[2]]
  RHS <- paste(attr(terms(formula), "term.labels"), collapse = " + ")
  selection.formula <- formula(paste(LHS, "~", RHS))

  tryCatch(
    type <- match.arg(type, c("MAP", "MPM", "BMA", "BMAfull")),
    error = function(e) stop(paste("Invalid value for type: ", type))
  )
  tryCatch(
    baseline <- match.arg(baseline, c("cox", "shrunk")),
    error = function(e) stop("Invalid baseline specification")
  )

  time.var <- as.character(formula[[2]][[2]])
  status.var <- as.character(formula[[2]][[3]])

  # Set up the g-prior
  nEvents <- sum(data[[status.var]])

  prior.hypergn <- CustomGPrior(logDens = function(g) {
    return(-log(nEvents) - 2 * log1p(g / nEvents))
  })

  #############################################################################################
  # Handle Global Empirical Bayes
  # First we need to fit the model, then we can hand a fixed g to the normal search procedure
  if (globalEB == TRUE) {
    full.model.space <- 2^length(labels(terms(selection.formula)))

    gEB.models <- glmBayesMfp(selection.formula,
      censInd = data[[status.var]],
      data = data,
      tbf = TRUE,
      empiricalBayes = TRUE,
      priorSpecs = list(gPrior = prior.hypergn, modelPrior = "dependent"),
      nModels = full.model.space,
      method = "exhaustive",
      verbose = FALSE
    )

    k <- length(gEB.models)
    deviances <- sapply(1:k, function(i) gEB.models[[i]]$information$residualDeviance)
    log.prior.prob <- sapply(1:k, function(i) gEB.models[[i]]$information$logPrior)

    ucList <- attr(gEB.models, "indices")$ucList
    degrees <- sapply(1:k, function(i) {
      length(unlist(ucList[gEB.models[[i]]$configuration$ucTerms]))
    })
    valid <- is.na(deviances) != TRUE

    TBF <- function(g) sum(((g + 1)^(-degrees / 2) * exp(g / (g + 1) * deviances / 2) * exp(log.prior.prob))[valid])

    globalEB.fun <- function(g) sapply(g, TBF)

    bestg <- optimise(f = globalEB.fun, interval = c(0.5, 1000), maximum = TRUE)$maximum
    print(paste("Global EB chooses g =", bestg))
  }
  # end globalEB
  #############################################################################################

  args1 <- list(selection.formula,
    censInd = data[[status.var]],
    data = data,
    tbf = TRUE,
    priorSpecs = list(gPrior = prior.hypergn, modelPrior = "dependent"),
    chainlength = 5000,
    method = "sampling",
    verbose = FALSE
  )

  inargs <- list(...)

  if (IC != FALSE) inargs <- c(inargs, fixedg = 10 * nrow(data))

  if (globalEB && exists("bestg")) {
    inargs <- c(inargs, fixedg = bestg)
  }

  # match args and ...
  if (length(inargs)) {
    for (i in seq_along(inargs)) {
      args1[[names(inargs)[i]]] <- inargs[[i]]
    }
  }

  # fit the model using TBF method
  models <- do.call(glmBayesMfp, args1)

  this.call <- match.call()

  if (globalEB) {
    geb <- which(names(this.call) == "globalEB")
    names(this.call)[geb] <- "fixedg"
    this.call[geb] <- bestg
  }

  # If we are doing AIC/BIC we need to fit models, calculate IC values and new probabilities.
  if (IC != FALSE && type != "BMAfull") {
    IC.values <- numeric(length(models))
    nullModel <- NA


    design.names <- colnames(attr(models, "data")$xCentered)

    new.data <- data.frame(cbind(
      status.var = attr(models, "data")$censInd,
      time.var = attr(models, "data")$y,
      attr(models, "data")$xCentered[, -1]
    ))

    colnames(new.data)[1:2] <- c(status.var, time.var)



    for (j in seq_along(models)) {
      # new.design.matrix <- getDesignMatrix(object=models[j])[,-1,drop=FALSE]
      #
      # new.data <- data.frame(cbind(status.var=attributes(models[j])$data$censInd,
      #                              time.var=attributes(models[j])$data$y,
      #                              new.design.matrix))
      #
      # colnames(new.data)[1:2] <- c(status.var,time.var)

      # covariate indices corresponding to data frame
      ind <- unlist(attr(models, "indices")$ucList[models[[j]]$configuration$ucTerms])


      model.formula <- reformulate(
        setdiff(colnames(new.data), c(time.var, status.var)),
        response = paste("survival::Surv(", time.var, ",", status.var, ")")
      )

      model.cph <- rms::cph(formula(model.formula), data = new.data, surv = FALSE, se.fit = FALSE, y = FALSE, x = FALSE)

      # if(j%%10==0) print(j)


      if (IC == "AIC") IC.values[j] <- -AIC(model.cph) / 2

      if (IC == "BIC") IC.values[j] <- -AIC(model.cph, k = log(sum(new.data[status.var]))) / 2

      # save this model so we can delete it
      if (is.na(IC.values[j]) || length(models[[j]]$configuration$ucTerms) == 0) {
        nullModel <- j
      }
    }

    # delete null model since it is can't be used later
    if (!is.na(nullModel)) {
      IC.values <- IC.values[-nullModel]
      models <- models[-nullModel]
    }
    models.df <- as.data.frame(models)


    IC.posteriors <- exp((IC.values - max(IC.values)) + models.df$logPrior)
    IC.posteriors <- IC.posteriors / sum(IC.posteriors)

    if (type == "MPM") {
      attr(models, "inclusionProbs") <- apply(models.df[, -(1:3)], 2, function(x) sum(x * IC.posteriors))
    }

    if (type == "MAP") {
      models[1] <- models[which.max(IC.posteriors)]
      # also include inclusion probs for *IC methods
      attr(models, "inclusionProbs") <- apply(models.df[, -(1:3)], 2, function(x) sum(x * IC.posteriors))
    }
  }
  # End AIC/BIC





  if (type == "MAP") {
    model.listpart <- models[1]

    # if overrideConfig exists, we use it instead of MPM to fit the desired model.
    if (!missing(overrideConfig)) {
      print("Using overrideConfig model")

      new.models <- computeModels(list(overrideConfig), models)
      model.listpart <- new.models[1]
    }
  } else if (type == "MPM") {
    # what are the covariates with inclusion probability >0.5?
    mpm.vars <- attr(models, "inclusionProbs") > 0.5
    # which model includes only these?
    model.df <- as.data.frame(models)[, -c(1:3)]
    mpm.index <- which(sapply(seq_along(models), function(i) all(model.df[i, ] == mpm.vars)))
    if (!any(mpm.index)) {
      # if the mpm wasn't fitted we must construct it
      print("MPM model wasn't fitted so we construct it.")
      mpm.model.config <- models[[1]]$configuration
      mpm.model.config$ucTerms <- which(mpm.vars)

      new.models <- computeModels(list(mpm.model.config), models)
      model.listpart <- new.models[1]
      # print("Success.s")
    } else {
      model.listpart <- models[mpm.index]
    }
  } else if (type == "BMAfull") {
    # BMA-FULL ----------------------------------------------------------------
    bma.surv <- list()
    bma.coefs <- list()
    bma.survfits <- list()
    surv.time <- numeric()

    models[which(sapply(
      seq_along(models),
      function(i) length(models[i][[1]]$configuration$ucTerms)
    ) == 0)] <- NULL

    # if we are doing AIC or BIC we need to calculate (and store) the values separately
    if (IC != FALSE) IC.values <- numeric(length(models))

    for (j in seq_along(models)) {
      new.design.matrix <- getDesignMatrix(object = models[j], intercept = FALSE)

      new.data <- data.frame(cbind(
        status.var = attributes(models[j])$data$censInd,
        time.var = attributes(models[j])$data$y,
        new.design.matrix
      ))

      colnames(new.data)[1:2] <- c(status.var, time.var)

      model.formula <- reformulate(
        setdiff(colnames(new.data), c(time.var, status.var)),
        response = paste("survival::Surv(", time.var, ",", status.var, ")")
      )

      # calculate values for each model
      bma.coefs[[j]] <- getModelCoefs(models[j],
        mcmc = McmcOptions(burnin = 0L, step = 1L, samples = 100)
      )
      # print(colnames(new.data))
      model.cph <- rms::cph(
        formula(model.formula),
        data = new.data,
        surv = TRUE,
        se.fit = FALSE,
        y = TRUE,
        x = TRUE
      )
      if (j == 1) surv.time <- model.cph$time

      if (baseline == "cox") {
        bma.surv[[j]] <- rms::Survival(model.cph)

        shrunk.survfit <- survival::survfit(model.cph)
        shrunk.surv <- c(1, shrunk.survfit$surv)
        if (length(shrunk.surv) < length(model.cph$surv)) {
          shrunk.surv <- c(shrunk.surv, shrunk.surv[length(shrunk.surv)])
        }
        bma.survfits[[j]] <- shrunk.surv
      }

      if (baseline == "shrunk") {
        # Take cox model object, put in shrunken coefficients, re-estimate baseline hazard
        shrunk.cph <- model.cph
        shrunk.mm <- new.design.matrix # model.matrix(model.formula, data=data)[,-1]
        #     shrunk.mm <-scale(shrunk.mm)
        shrunk.cph$linear.predictors <- shrunk.mm %*% bma.coefs[[j]]


        # shrunk.survfit <- survival::survfit(shrunk.cph)

        shrunk.survfit <- try(survival::survfit(shrunk.cph))

        if (class(shrunk.survfit)[1] == "try-error") {
          this.model <- models[j]
          these.coefs <- bma.coefs[[j]]
          save("model.cph", "shrunk.mm", "these.coefs", "this.model", file = "Faulty.Files.Rdata")

          g <- exp(models[[j]]$information$zMode)
          shrunk.cph$linear.predictors <- shrunk.mm %*% (model.cph$coefficients * g / (g + 1))
          shrunk.survfit <- try(survival::survfit(shrunk.cph))
        }


        shrunk.surv <- c(1, shrunk.survfit$surv)
        if (length(shrunk.surv) < length(model.cph$surv)) {
          shrunk.surv <- c(shrunk.surv, shrunk.surv[length(shrunk.surv)])
        }
        shrunk.cph$surv <- shrunk.surv

        bma.surv[[j]] <- rms::Survival(shrunk.cph)

        bma.survfits[[j]] <- shrunk.surv
      }


      if (IC != FALSE) {
        if (IC == "AIC") IC.values[j] <- -AIC(model.cph) / 2
        if (IC == "BIC") IC.values[j] <- -AIC(model.cph, k = log(sum(new.data[status.var]))) / 2
      }
    }

    # unlist gives the factor levels the wrong names, so take the better ones
    # from cph to avoid confusion!
    #   names(model.coefs) <- names(model.cph$coefs)

    ret <- list()

    ret$formula <- writeFormula(models[1], time.var, status.var) # model.formula
    ret$coefs <- bma.coefs
    ret$data <- data
    ret$call <- this.call


    if (IC == FALSE) {
      ret$probability <- posteriors(models)
    } else if (IC != FALSE) {
      log.priors <- unlist(lapply(models, function(i) i$information$logPrior))
      IC.posteriors <- exp((IC.values - max(IC.values)) + log.priors)
      ret$probability <- IC.posteriors / sum(IC.posteriors)
    }

    ret$survfit <- matrix(unlist(bma.survfits), byrow = TRUE, nrow = length(bma.survfits))
    ret$time <- surv.time
    ret$bma.surv <- bma.surv
    ret$model.object <- models # just save the first one for space
    class(ret) <- "TBFcox.BMA"
    return(ret)
  } else if (type == "BMA") {
    # check for null models and remove them. The fitting procedure can't handle them
    # this might be a bit dodgy, but no alternative solution comes to mind
    isNull <- apply(as.data.frame(models)[, -(1:3)], 1, sum) == 0
    models[isNull] <- NULL

    if (IC != FALSE) {
      sbma <- sampleBma(models, postProbs = IC.posteriors[!isNull])
    } else {
      sbma <- sampleBma(models)
    }

    #     uc.included <- which(unlist(lapply(sbma$samples@ucCoefs, function(x) is.numeric(mean(x)))))
    uc.included <- which(apply(as.data.frame(models)[, -c(1:3)], 2, any))


    fake.model <- models[1]
    fake.model[[1]]$information <- list()

    uc.num.inc <- which(attr(fake.model, "termNames")$uc %in% names(uc.included))

    fake.model[[1]]$configuration <- list(powers = list(), ucTerms = uc.num.inc)

    new.design.matrix <- getDesignMatrix(object = fake.model, intercept = FALSE)


    # get coefficients for BMA
    #     if(BMA.method=="coefs"){
    #       bma.coefs <- unlist(lapply(sbma$samples@ucCoefs, rowSums))/sbma$samples@nSamples
    #     }

    #     if(BMA.method=="fits"){
    bma.coefs <- .lm.fit(x = new.design.matrix, y = rowMeans(sbma$samples@fitted))$coefficients
    #     }

    # things were out of order making predictions terrible!
    #     bma.coefs <- bma.coefs[order(names(bma.coefs))]
    names(bma.coefs) <- colnames(new.design.matrix)

    new.data <- data.frame(cbind(
      status.var = attributes(fake.model)$data$censInd,
      time.var = attributes(fake.model)$data$y,
      new.design.matrix
    ))

    colnames(new.data)[1:2] <- c(status.var, time.var)

    model.formula <- reformulate(
      setdiff(colnames(new.data), c(time.var, status.var)),
      response = paste("survival::Surv(", time.var, ",", status.var, ")")
    )

    model.cph <- rms::cph(
      formula(model.formula),
      data = new.data,
      surv = TRUE,
      se.fit = FALSE,
      y = TRUE,
      x = TRUE
    )

    if (baseline == "cox") {
      bma.surv <- rms::Survival(model.cph)
    }

    if (baseline == "shrunk") {
      # Take cox model object, put in shrunken coefficients, re-estimate baseline hazard
      shrunk.cph <- model.cph
      shrunk.mm <- new.design.matrix # model.matrix(model.formula, data=data)[,-1]
      #     shrunk.mm <-scale(shrunk.mm)
      shrunk.cph$linear.predictors <- shrunk.mm %*% bma.coefs
      shrunk.survfit <- survival::survfit(shrunk.cph)
      shrunk.surv <- c(1, shrunk.survfit$surv)
      if (length(shrunk.surv) < length(model.cph$surv)) {
        shrunk.surv <- c(shrunk.surv, shrunk.surv[length(shrunk.surv)])
      }
      shrunk.cph$surv <- shrunk.surv

      bma.surv <- rms::Survival(shrunk.cph)
    }

    # unlist gives the factor levels the wrong names, so take the better ones
    # from cph to avoid confusion!
    #   names(model.coefs) <- names(model.cph$coefs)
    ret <- list()

    # ret$formula <- writeFormula(models[1], time.var, status.var) #model.formula
    ret$formula <- formula(
      paste(
        "survival::Surv(", time.var, ",", status.var, ") ~",
        paste(paste(names(sbma$samples@ucCoefs)), collapse = " + ")
      )
    )
    ret$coefs <- bma.coefs
    ret$data <- data
    ret$call <- this.call


    ret$survival <- bma.surv
    ret$model.object <- fake.model # just save the first one for space
    class(ret) <- "TBFcox"
    return(ret)
  }
  #############################################################################################################

  if (type %in% c("MAP", "MPM")) {
    if (!keepModelList) rm(models)

    new.design.matrix <- getDesignMatrix(object = model.listpart, intercept = FALSE)

    new.data <- data.frame(cbind(
      status.var = attributes(model.listpart)$data$censInd,
      time.var = attributes(model.listpart)$data$y,
      new.design.matrix
    ))

    colnames(new.data)[1:2] <- c(status.var, time.var)

    model.formula <- reformulate(
      setdiff(colnames(new.data), c(time.var, status.var)),
      response = paste("survival::Surv(", time.var, ",", status.var, ")")
    )

    # Do the original shortcut way, using E(beta) in the exp.
    if (sep == FALSE) {
      model.coefs <- getModelCoefs(model.listpart, sep = FALSE)
      model.formula <- reformulate(
        setdiff(colnames(new.data), c(time.var, status.var)),
        response = paste("survival::Surv(", time.var, ",", status.var, ")")
      )
      model.cph <- rms::cph(
        formula(model.formula),
        data = new.data,
        surv = TRUE,
        se.fit = FALSE,
        y = TRUE,
        x = TRUE
      )

      ret <- list()

      ret$formula <- writeFormula(model.listpart, time.var, status.var) # model.formula
      ret$coefs <- model.coefs
      ret$data <- data
      ret$call <- this.call
      ret$survival <- function() {}
      ret$model.object <- model.listpart
      if (exists("models")) ret$model.list <- models

      if (baseline == "shrunk") {
        # Take cox model object, put in shrunken coefficients, re-estimate baseline hazard
        shrunk.cph <- model.cph
        shrunk.mm <- new.design.matrix # model.matrix(model.formula, data=data)[,-1]

        shrunk.cph$linear.predictors <- shrunk.mm %*% model.coefs
        shrunk.survfit <- survival::survfit(shrunk.cph)
        shrunk.surv <- c(1, shrunk.survfit$surv)
        if (length(shrunk.surv) < length(model.cph$surv)) {
          shrunk.surv <- c(shrunk.surv, shrunk.surv[length(shrunk.surv)])
        }
        shrunk.cph$surv <- shrunk.surv

        ret$survival <- rms::Survival(shrunk.cph)
      } else if (baseline == "cox") {
        ret$survival <- rms::Survival(model.cph)
      }

      class(ret) <- "TBFcox"
      return(ret)
    }

    # Do the full way with E(h_i(t)exp(beta))
    if (sep == TRUE) {
      model.coefs <- getModelCoefs(model.listpart, sep = TRUE)
      model.formula <- reformulate(
        setdiff(colnames(new.data), c(time.var, status.var)),
        response = paste("survival::Surv(", time.var, ",", status.var, ")")
      )
      model.cph <- rms::cph(
        formula(model.formula),
        data = new.data,
        surv = TRUE,
        se.fit = FALSE,
        y = TRUE,
        x = TRUE
      )

      ret <- list()

      ret$formula <- writeFormula(model.listpart, time.var, status.var) # model.formula

      ret$data <- data
      ret$call <- this.call

      ret$model.object <- model.listpart
      if (exists("models")) ret$model.list <- models

      ret$survival <- vector(mode = "list", length = length(model.coefs))
      ret$coefs <- model.coefs


      if (baseline == "shrunk") {
        # Take cox model object, put in shrunken coefficients, re-estimate baseline hazard
        shrunk.cph <- model.cph
        shrunk.mm <- new.design.matrix # model.matrix(model.formula, data=data)[,-1]

        for (k in seq_along(model.coefs)) {
          shrunk.cph$linear.predictors <- shrunk.mm %*% model.coefs[[k]]
          shrunk.survfit <- survival::survfit(shrunk.cph)
          shrunk.surv <- c(1, shrunk.survfit$surv)
          if (length(shrunk.surv) < length(model.cph$surv)) {
            shrunk.surv <- c(shrunk.surv, shrunk.surv[length(shrunk.surv)])
          }
          shrunk.cph$surv <- shrunk.surv

          ret$survival[[k]] <- rms::Survival(shrunk.cph)
        }
      } else if (baseline == "cox") {
        for (k in seq_along(model.coefs)) {
          ret$survival[[k]] <- rms::Survival(model.cph)
        }
      }

      class(ret) <- "TBFcox.sep"
      return(ret)
    }
  } # end MAP/MPM
} # end function

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[getDesignMatrix.R] by DSB Die 16/02/2010 13:13 (CET)>
##
## Description:
##  Construct the design matrix for a given model configuration and GlmBayesMfp object.
##
## History:
## 06/01/2010   copy from package bfp, slightly modify signature and add Roxygen comments
## 07/07/2015   add center argument if we want the uncentered design matrix.
#####################################################################################

##' @include helpers.R
##' @include getFpTransforms.R
NULL

##' Construct the design matrix for a given bfp GLM model
##'
##' This is an internal function to construct the (centered) design matrix for a given
##' bfp GLM model.
##'
##' @param modelConfig the model configuration list which must have elements
##' \dQuote{powers} and \dQuote{powers}. Defaults to the configuration of the first element of
##' @param object the \code{GlmBayesMfp} object, which is needed because it contains
##' the covariates matrix and indices vector
##' @param intercept return the intercept column inside the matrix (default) or not?
##' @param center should the data be centered (default) or not?
##' @return The design matrix, where the non-fixed part is columnwise centered (that is, the
##' colmeans are zero).
##'
##' @keywords internal utilities
getDesignMatrix <- function(modelConfig = object[[1]]$configuration,
                            object,
                            intercept = TRUE,
                            center = TRUE) {
  ## checks
  stopifnot(is.bool(intercept))

  ## extract covariates matrices from object
  data <- attr(object, "data")
  full <- data$x
  fullCentered <- data$xCentered

  ## also extract index vector
  inds <- attr(object, "indices")

  ## then get powers / ucs from the model configuration
  powers <- modelConfig$powers
  ucSet <- modelConfig$ucTerms
  fixSet <- modelConfig$fixTerms

  ## now the real code starts:

  ## check that only one covariate (the intercept) is fixed
  nFix <- sum(inds$fixed != 0)
  # stopifnot(identical(nFix, 1L))

  ## see how many ucs and fps are included
  ucColInds <- inds$uc %in% ucSet
  nUc <- sum(ucColInds)

  fixColInds <- inds$fix %in% fixSet


  nFp <- length(unlist(powers))

  ## so we know how much space to reserve for the return matrix
  nColumns <-
    if (intercept) {
      1 + nFix + nUc + nFp
    } else {
      nFix + nUc + nFp
    }

  ret <- matrix(
    nrow = nrow(full),
    ncol = nColumns
  )
  retColnames <- character(ncol(ret))

  ## invariant: already col columns written
  col <- 0

  if (intercept) {
    # add the intercept
    ret[, 1] <- full[, 1, drop = FALSE]
    col <- col + 1
  }

  ## fp part
  for (i in seq_along(inds$bfp)) {
    pi <- powers[[i]]
    if (len <- length(pi)) { # if there is at least one power
      new <- getFpTransforms(full[, inds$bfp[i], drop = FALSE], pi, center = center)
      newInds <- col + seq_along(pi)

      ret[, newInds] <- new
      retColnames[newInds] <- colnames(new)

      col <- col + len
    }
  }

  ## uc part
  if (length(ucSet)) {
    if (center) {
      new <- fullCentered[, ucColInds, drop = FALSE]
    } else if (!center) {
      new <- full[, ucColInds, drop = FALSE]
    }
    newInds <- col + seq_len(nUc)

    ret[, newInds] <- new
    retColnames[newInds] <- colnames(new)

    col <- col + nUc
  }


  # add any other fixed cols
  if (length(fixSet)) {
    if (center) {
      new <- fullCentered[, fixColInds, drop = FALSE]
    } else if (!center) {
      new <- full[, fixColInds, drop = FALSE]
    }

    newInds <- col + seq_len(sum(fixColInds)) # nFix-1 because we already put the intercept in
    ret[, newInds] <- new
    retColnames[newInds] <- colnames(new)

    col <- col + nFix
  }

  ## attach dimnames
  rownames(ret) <- rownames(full)
  colnames(ret) <- retColnames

  ## and then return the design matrix
  return(ret)
}

#####################################################################################
## Author: Isaac Gravestock [isaac *.* gravestock *a*t* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Description:
## Transform variables in formulas with fractional polynomials
##
## History:
## 14/07/2015 Copy from CoxTBFs project
#####################################################################################


##' Transform formula variables
##'
##' Simple function to apply the Box Tidwell transformation to a variables in a formula.
##' Variable is first shifted and scaled
##' NewVar = (Var+shift)/scale
##' then transformed and optionally centered.
##' Can be used in formulas as poly() is.
##'
##' @param var the variable to transform
##' @param powers one or more powers
##' @param scale value to scale the variable after shifting (default=1)
##' @param shift value to shift the variable by (default=0)
##' @param center center the variable when transforming.
##'
##' @return the transformed vector
##' @keywords utilities
##' @export
##'

fpTrans <- function(var, powers = 1, scale = 1, shift = 0, center = TRUE) {
  varname <- deparse(substitute(var))

  varm <- as.matrix(var)

  newname <- if (shift != 0) {
    paste("(", varname, "+", shift, ")", sep = "")
  } else {
    varname
  }
  if (scale != 1) newname <- paste(newname, "/", scale, sep = "")

  colnames(varm) <- newname

  if (scale == 0) stop("Attempting to scale (divide) by 0 in fpTrans")

  varm <- (varm + shift) / scale

  #   out <- matrix(nrow=length(var), ncol=length(powers))

  res <- getFpTransforms(vec = varm, powers = powers, center = center)
  return(res)
}

#####################################################################################
## Author: Isaac Gravestock [isaac *.* gravestock *a*t* uzh *.* ch]
## Project: BFPs for GLMs
##
## Description:
## Estimate shrunken coefficients from GlmBayesMfp object for Cox model
##
## History:
## 14/07/2015 Copied from CoxTBFs project functions-funsel-2.bma.R
#####################################################################################

##' @include sampleBma.R
##' @include getDesignMatrix.R
NULL

##' Estimate shrunken coefficients from GlmBayesMfp object for Cox model
##'
##' This is an internal function to estimate shrunken coefficients from GlmBayesMfp object
##' for Cox models. It calls \code{\link{sampleBma}} and then calculates coefficents based
##' on a linear fit.
##'
##' @param model.listpart the glmBfp object for which to construct the survival formula
##' @param ... additional arguments to pass to \code{\link{sampleBma}}
##' @param sep should coefficients be returned separately (default=FALSE)
##' @return A named vector of coefficients.
##'
##' @keywords internal utilities

getModelCoefs <- function(model.listpart, mcmc, sep = FALSE, ...) {
  DM <- getDesignMatrix(object = model.listpart, intercept = FALSE)
  n.coefs <- dim(DM)[2]

  if (n.coefs == 0) {
    return(0)
  }

  if (sep == FALSE) {
    mcmc.obj <- McmcOptions()
  } else {
    mcmc.obj <- McmcOptions(samples = 200)
  }

  if (methods::hasArg(mcmc)) mcmc.obj <- mcmc

  model.bma <- sampleBma(model.listpart, mcmc = mcmc.obj, verbose = FALSE)


  #  print("break!")
  all.coefs <- lapply(seq_len(ncol(model.bma$samples@fitted)), function(i) {
    if (sum(is.na(model.bma$samples@fitted[, i])) > 0) {
      print("This iteration from sampleBMA didn't work, return NA!")
      return(rep(NA, length(model.bma$samples@fitted[, i])))
    }
    result <- .lm.fit(x = as.matrix(DM), y = model.bma$samples@fitted[, i])$coefficients
    return(result)
  })

  if (sep == FALSE) {
    if (n.coefs > 1) {
      arr <- array(unlist(all.coefs), dim = c(length(all.coefs[[1]]), length(all.coefs)))
      ret.all.coefs <- rowMeans(arr, na.rm = TRUE)
      #     ret.all.coefs <- rowMeans(all.coefs,na.rm=TRUE)
    } else {
      ret.all.coefs <- mean(unlist(all.coefs), na.rm = TRUE)
    }

    names(ret.all.coefs) <- colnames(DM)

    return(ret.all.coefs)
  } else if (sep == TRUE) {
    return(all.coefs)
  }
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[plotCurveEstimate.R] by DSB Mit 23/01/2013 18:14 (CET)>
##
## Description:
## Plot predictor curve estimates for a given samples object, produced by sampleGlm.
##
## History:
## 07/01/2010   copy and modify from package bfp (no method, add Roxygen chunks etc)
## 25/05/2010   expect input of S4 class "GlmBayesMfpSamples";
##              change expected layout of samples matrices (now nParameters x
##              nSamples)
## 03/08/2010   rug must be painted after the matplot call
#####################################################################################

##' @include hpds.R
NULL

##' Function for plotting a fractional polynomial curve estimate
##'
##' Plot a fractional polynomial curve estimate using samples from a single
##' GLM / Cox model or a model average.
##'
##' @param samples an object of class \code{\linkS4class{GlmBayesMfpSamples}},
##' produced by \code{\link{sampleGlm}} and \code{\link{sampleBma}}.
##' @param termName string denoting an FP term, as written by the
##' \code{\link[=as.data.frame.GlmBayesMfp]{as.data.frame}} method
##' @param plevel credible level for pointwise HPD, and \code{NULL} means
##' no pointwise HPD (default: 0.95). The pointwise intervals are plotted in
##' blue color.
##' @param slevel credible level for simultaneous credible band (SCB),
##' \code{NULL} means no SCB (defaults to \code{plevel}). The simultaneous
##' intervals are plotted in green color.
##' @param plot if \code{FALSE}, only return values needed to produce the
##' plot, but do not plot (default is \code{TRUE}, so a plot is made)
##' @param rug add a rug to the plot? (default: \code{FALSE})
##' @param addZeros include zero samples for models where the covariate is not
##' included? (default: \code{FALSE}) If \code{TRUE}, this changes the
##' interpretation of the samples, and therefore curve estimates based on these
##' samples: it is no longer conditional on inclusion of the covariate, but
##' marginally over all models, also those not including the covariate.

##' @param \dots further arguments for plotting with \code{\link{matplot}}
##' @return a list of various plotting information:
##' \item{original}{grid on the original covariate scale}
##' \item{grid}{grid on the transformed scale}
##' \item{mean}{pointwise mean curve values}
##' \item{plower}{lower boundaries for pointwise HPD}
##' \item{pupper}{upper boundaries for pointwise HPD}
##' \item{slower}{lower boundaries for SCB}
##' \item{supper}{upper boundaries for SCB}
##' \item{obsVals}{observed values of the covariate on the original scale}
##' \item{partialResids}{not implemented: partial residuals}
##' \item{transform}{vector of shift and scale parameter}
##'
##' @keywords regression
##'
##' @importFrom graphics abline curve matplot par
##' @importFrom methods is
##'
##' @export
plotCurveEstimate <-
  function(samples,
           termName,
           plevel = 0.95,
           slevel = plevel,
           plot = TRUE,
           rug = FALSE,
           addZeros = FALSE,
           ...) {
    ## check class of "samples"
    stopifnot(is(samples, "GlmBayesMfpSamples"))

    ## extract samples and its attributes (they might be overwritten by cbind
    ## below)
    mat <- samples@bfpCurves[[termName]]
    attrs <- attributes(mat)

    ## check that there are samples for this covariate
    if (is.null(mat)) {
      stop("There were no samples which include ", termName, " in this model sample!\n")
    }
    ## add zeros? todo: this should also work if no samples include this covariate!
    if (addZeros) {
      mat <- cbind(
        mat,
        matrix(
          data = 0,
          nrow = nrow(mat),
          ncol = (samples@nSamples - ncol(mat))
        )
      )
    }

    ## start return list
    ret <- list()

    ## x values
    ret$grid <- g <- as.vector(attrs$scaledGrid)
    tr <- samples@shiftScaleMax[termName, c("shift", "scale")]
    ret$original <- g * tr[2] - tr[1]

    ## compute pwise data
    ret$mean <- rowMeans(mat, na.rm = TRUE)

    if (!is.null(plevel)) {
      plowerUpper <- apply(mat, 1, empiricalHpd, level = plevel)
      ret$plower <- plowerUpper[1, ]
      ret$pupper <- plowerUpper[2, ]
    }

    ## simultaneous credible band around the mean
    if (!is.null(slevel)) {
      bandData <- scrHpd(mat, level = slevel, mode = ret$mean)
      ret$slower <- bandData[, "lower"]
      ret$supper <- bandData[, "upper"]
    }

    ## todo: add generalized partial residuals?

    ## ## partial residuals, attention because of possible ties between observed grid values in data!
    ## resids <- residuals (model)

    pos <- attrs$whereObsVals

    ## partialResids <- ret$mean[pos] + resids
    partialResids <- NULL

    if (plot) {
      ## determine plotting arguments for matlines
      matplotList <- list(...)
      if (is.null(matplotList$xlab)) {
        matplotList$xlab <- termName
      }
      if (is.null(matplotList$ylab)) {
        front <- paste("Average partial predictor g(", termName, ")", sep = "")
        if (any(tr != c(0, 1))) {
          middle <- " after the transform "
          back <-
            if (tr[1] != 0) {
              if (tr[2] != 1) {
                paste(termName, "%<-% (", termName, " + ", tr[1], ") %/% ", tr[2])
              } else {
                paste(termName, "%<-%", termName, " + ", tr[1])
              }
            } else {
              paste(termName, "%<-%", termName, "%/%", tr[2])
            }
          annotation <- substitute(
            expression(paste(f, m, b)),
            list(
              f = front,
              m = middle,
              b = parse(text = back)[[1]]
            )
          )
        } else {
          annotation <- front
        }
        matplotList$ylab <- eval(annotation)
      }
      if (is.null(matplotList$lty)) {
        matplotList$lty <- 1
      }
      if (is.null(matplotList$col)) {
        matplotList$col <- c("black", "blue", "blue", "green", "green")
      }
      if (is.null(matplotList$type)) {
        matplotList$type <- "l"
      }
      matplotList$x <- ret$original
      matplotList$y <- as.data.frame(ret[-match(c("original", "grid"), names(ret))])

      if (is.null(matplotList$ylim)) {
        matplotList$ylim <- range(c(partialResids, matplotList$y))
      }

      ## and plot:

      ## first the points
      ret$obsVals <- ret$original[pos]
      ret$partialResids <- partialResids
      ## plot(ret$obsVals, ret$partialResids,
      ##      type="p",
      ##      xlab=matplotList$xlab,
      ##      ylab=matplotList$ylab,
      ##      ylim=matplotList$ylim,
      ##      cex = 0.5,
      ##      col = "gray")

      ## then the curves, so that they are not over painted over by points
      ## matplotList$add <- TRUE
      do.call(matplot, matplotList)

      ## possibly the rug
      rug <- as.logical(rug)
      if (isTRUE(rug)) {
        rug(jitter(ret$obsVals), col = "gray")
      }
    }
    ret$transform <- tr

    invisible(ret)
  }

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs
##
## Time-stamp: <[getFamily.R] by DSB Mit 06/02/2013 10:54 (CET)>
##
## Description:
## Helper for glmBayesMfp which extracts an S3 family object with additional elements
## from an option.
##
## History:
## 12/02/2010   split from glmBayesMfp.R file
## 12/05/2010   add cauchit link, remove inverse link from the accepted links
##              because we cannot deal with that in the generalized g-prior
##              framework.
## 06/02/2013   check for missing family, since there is no longer a default
##              in glmBayesMfp
#####################################################################################


##' Helper function for glmBayesMfp: Extracts an S3 family object
##'
##' Extracts an S3 family object, which (at least) the usual elements
##' "family", "link", "linkfun", "linkinv", "variance", "mu.eta", "dev.resids",
##' plus the additional elements:
##' "phi" which includes just the dispersion parameter to be used,
##' and "simulate" which can generate random variates for a given linear predictor and weight vector
##' (this function of course also uses the "phi" value)
##'
##' @param family the family argument passed to \code{\link{glmBayesMfp}}
##' @param phi the dispersion argument passed to \code{\link{glmBayesMfp}}
##'
##' @return The returned family object also includes a custom \sQuote{init} function,
##' which takes the response vector (or matrix) (\sQuote{y}) and the corresponding weight vector
##' (\sQuote{weights}), processes them to response vector \sQuote{y} and possibly altered weights
##' \sQuote{weights}, and includes starting values \sQuote{mustart} for the IWLS algorithm.
##' For example, here the binomial special case of two-column-response matrix is treated exactly in
##' the same way as in \code{\link{glm}}.
##'
##' @keywords internal
getFamily <- function(family,
                      phi) {
  if (missing(family)) {
    stop(simpleError("Option family must be specified!"))
  }

  ## check that dispersion is positive etc.
  phi <- as.numeric(phi)
  stopifnot(
    identical(length(phi), 1L),
    phi > 0
  )

  ## then process the family argument:

  ## convert character to function
  if (is.character(family)) {
    family <- get(family, mode = "function")
  }
  ## call function to get object
  if (is.function(family)) {
    family <- family()
  }
  ## check that family has correct form
  stopifnot(
    inherits(family, "family"),
    all(
      c("family", "link", "linkfun", "linkinv", "variance", "mu.eta", "dev.resids") %in%
        names(family)
    )
  )

  ## check here if family and link are supported.
  ## (we only want to use links which always map into the valid mu space)

  ## first check the family,
  ## and along the way, we force the dispersion parameter
  ## and also choose which links are supported for that family.
  if (identical(family$family, "binomial")) {
    okLinks <- c("logit", "cauchit", "probit", "cloglog")
    family$phi <- 1
    family$simulate <- function(eta, weights) {
      ## check if weights are non-negative integers
      stopifnot(
        all((weights %% 1L) == 0L),
        all(weights >= 0L)
      )

      ## then simulate one observation for each lin pred value
      rbinom(
        n = length(eta),
        size = weights,
        prob = family$linkinv(eta)
      )
    }
  } else if (identical(family$family, "gaussian")) {
    okLinks <- c("log", "identity")
    family$phi <- phi
    family$simulate <- function(eta, weights) {
      rnorm(
        n = length(eta),
        mean = family$linkinv(eta),
        sd = sqrt(phi / weights)
      )
    }
  } else if (identical(family$family, "poisson")) {
    okLinks <- c("log")
    family$phi <- 1
    family$simulate <- function(eta, weights) {
      ## here we do not use the weights at all!
      rpois(
        n = length(eta),
        lambda = family$linkinv(eta)
      )
    }
  } else {
    stop(simpleError(paste(
      "family",
      family$family,
      "not supported"
    )))
  }


  ## warn if phi has changed
  if (family$phi != phi) {
    warning(simpleWarning(paste(
      "dispersion was changed from",
      phi,
      "to",
      family$phi
    )))
  }

  ## then check the link
  if (!(family$link %in% okLinks)) {
    stop(simpleError(paste(
      "link",
      family$link,
      "not supported for family",
      family$family
    )))
  }

  ## now attach a nicer initialize function, instead of just the expression e.g. in
  ## binomial()$initialize
  family$init <- function(y, # the response vector or matrix
                          weights, # the weights vector
                          nobs = length(weights)) { # number of observations

    ## create dummy variables which are sometimes needed in the
    ## initializer expression
    etastart <- start <- mustart <- NULL

    ## evaluate the initializer expression, which modifies y and weights
    ## and computes mustart values
    eval(family$initialize)

    ## return these
    return(list(
      y = y,
      weights = weights,
      linPredStart = family$linkfun(mustart)
    ))
    ## use start values on the linear predictor scale for ease and clarity in C++.
  }

  return(family)
}

#' Prediction methods for CoxTBF objects
#'
#' Predicts survival probabilities at given times. Compatible with predictSurvProb functions
#' required by \code{pec} package.
#'
#' @param object a model fitted with \code{\link{coxTBF}}
#' @param newdata a data frame with the same variables as the original data used to fit the object
#' @param times a vector of times to predict survival probability for
#' @param ... not used.
#'
#' @return A data frame of survival probabilities with rows for each row of newdata and columns for each time.
#' @export
#'
predict.TBFcox <- function(object, newdata = object$data, times, ...) {
  # print("predictSurvProb TBF.Cox")
  # print(paste("Train N =",nrow(attr(object$model.object,"data")$x),
  #             ". Predict N = ", nrow(newdata)))
  # From sampleGlm.R from glmBfp packages by Sabanes Bove
  obj <- object$model.object
  config <- obj[[1]]$configuration
  ## get new data matrix
  tempX <- constructNewdataMatrix(
    object = obj,
    newdata = newdata
  )

  ## copy old GlmBayesMfp object
  tempObj <- obj

  ## correct model matrix in tempMod to new data matrix
  attr(tempObj, "data") <-
    list(
      x = tempX,
      xCentered = scale(tempX, center = TRUE, scale = FALSE)
    )

  ## so we can get the design matrix

  # lets see what happens if we do this another way
  newDesignUC <- getDesignMatrix(
    modelConfig = config,
    object = tempObj,
    intercept = FALSE,
    center = FALSE
  )


  oldDesignUC <- getDesignMatrix(
    modelConfig = config,
    object = obj,
    intercept = FALSE,
    center = FALSE
  )

  oldMeans <- colMeans(oldDesignUC)

  for (i in seq_along(oldMeans)) {
    newDesignUC[, i] <- newDesignUC[, i] - oldMeans[i]
  }

  ## so the linear predictor samples are
  linPredSamples <- newDesignUC %*% object$coefs


  return(object$survival(times, linPredSamples))
}





#' Prediction methods for CoxTBF objects with separate estimates
#'
#' Predicts survival probabilities at given times. Compatible with predictSurvProb functions
#' required by \code{pec} package. Predicts objects with fitted with \code{sep=TRUE}
#'
#' @param object a model fitted with \code{\link{coxTBF}}
#' @param newdata a dataframe with the same variables as the original data used to fit the object
#' @param times a vector of times to predict survival probability for
#' @param ... not used.
#'
#' @return A data frame of survival probabilities with rows for each row of newdata and columns for each time.
#' @export
#'
#'
predict.TBFcox.sep <- function(object, newdata, times, ...) {
  print("predictSurvProb TBF.Cox.sep")
  print(paste(
    "Train N =", nrow(attr(object$model.object, "data")$x),
    ". Predict N = ", nrow(newdata)
  ))
  # From sampleGlm.R from glmBfp packages by Sabanes Bove
  obj <- object$model.object
  config <- obj[[1]]$configuration
  ## get new data matrix
  tempX <- constructNewdataMatrix(
    object = obj,
    newdata = newdata
  )

  ## copy old GlmBayesMfp object
  tempObj <- obj

  ## correct model matrix in tempMod to new data matrix
  attr(tempObj, "data") <-
    list(
      x = tempX,
      xCentered = scale(tempX, center = TRUE, scale = FALSE)
    )

  ## so we can get the design matrix

  # lets see what happens if we do this another way
  newDesignUC <- getDesignMatrix(
    modelConfig = config,
    object = tempObj,
    intercept = FALSE,
    center = FALSE
  )


  oldDesignUC <- getDesignMatrix(
    modelConfig = config,
    object = obj,
    intercept = FALSE,
    center = FALSE
  )

  oldMeans <- colMeans(oldDesignUC)

  for (i in seq_along(oldMeans)) {
    newDesignUC[, i] <- newDesignUC[, i] - oldMeans[i]
  }

  ## so the linear predictor samples are
  linPredSamples <- lapply(object$coefs, function(coefs) newDesignUC %*% coefs)

  k <- length(linPredSamples)

  ret.survival <- lapply(1:k, function(i) object$survival[[i]](times, linPredSamples[[i]]))

  ret.surv2 <- matrix(0, nrow = nrow(as.data.frame(ret.survival[[1]])), ncol = length(times))
  for (i in 1:k) {
    ret.surv2 <- ret.surv2 + ret.survival[[i]] / k
  }

  return(ret.surv2)
}




#' Prediction methods for CoxTBF objects for BMA models
#'
#' Predicts survival probabilities at given times. Compatible with predictSurvProb functions
#' required by \code{pec} package. Predicts BMA objects.
#'
#' @param object a model fitted with \code{\link{coxTBF}}
#' @param newdata a dataframe with the same variables as the original data used to fit the object
#' @param times a vector of times to predict survival probability for
#' @param ... not used.
#'
#' @return A data frame of survival probabilities with rows for each row of newdata and columns for each time.
#' @export
#'
#'
predict.TBFcox.BMA <- function(object, newdata, times, ...) {
  post <- object$probability / sum(object$probability)
  time <- object$time

  N <- nrow(newdata)
  k <- length(object$model.object)
  t <- length(times)

  preds <- matrix(0, nrow = t, ncol = N)
  Big.Matrix <- matrix(0, nrow = k, ncol = t)
  LP.Matrix <- matrix(0, nrow = N, ncol = k)
  W.Matrix <- diag(x = post)


  print(paste("Predict BMA", "N=", N, "k=", k, "t=", t))
  # Populate (exp) LP.Matrix
  # This can probably be made faster since I think some of the matrices are identical

  print("Making Model Matrices")
  for (i in seq_along(object$model.object)) {
    # From sampleGlm.R from glmBfp packages by Sabanes Bove
    obj <- object$model.object[i]
    config <- obj[[1]]$configuration
    ## get new data matrix
    tempX <- constructNewdataMatrix(
      object = obj,
      newdata = newdata
    )

    ## copy old GlmBayesMfp object
    tempObj <- obj

    ## correct model matrix in tempMod to new data matrix
    attr(tempObj, "data") <-
      list(
        x = tempX,
        xCentered = scale(tempX, center = TRUE, scale = FALSE)
      )

    ## so we can get the design matrix

    # lets see what happens if we do this another way
    newDesignUC <- getDesignMatrix(
      modelConfig = config,
      object = tempObj,
      intercept = FALSE,
      center = FALSE
    )


    oldDesignUC <- getDesignMatrix(
      modelConfig = config,
      object = obj,
      intercept = FALSE,
      center = FALSE
    )

    oldMeans <- colMeans(oldDesignUC)

    newDesignUC <- newDesignUC - rep(oldMeans, each = nrow(newDesignUC))

    ## so the linear predictor samples (after exp transform) are
    LP.Matrix[, i] <- exp(newDesignUC %*% object$coefs[[i]])
  }

  print("Making Big Matrix")
  # Populate Big.Matrix
  for (i in 1:t) {
    tm <- max((seq_along(time))[time <= times[i] + 1e-06])
    Big.Matrix[, i] <- object$survfit[, tm]
    if (times[i] > max(time) + 1e-06) {
      Big.Matrix[, i] <- NA
    }
  }

  print("Making Predictions")
  #   for(i in 1:k){
  #     print(paste("p=",i,"of",k))
  #     preds <- preds + post[i]* outer(Big.Matrix[i,], LP.Matrix[,i], "^")
  #   }
  preds <- predBMAcpp(Big.Matrix, LP.Matrix, post)

  print("Finished Predictions")
  preds <- t(preds)
  if (is.data.frame(preds)) colnames(preds) <- times
  return(preds)
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[sampleGlm.R] by DSB Mon 26/08/2013 15:43 (CEST)>
##
## Description:
## Produce posterior samples from one GLM returned by glmBayesMfp, using an MCMC sampler.
##
## History:
## 10/12/2009   file creation
## 05/01/2010   construct the random number generator for the marginal z approximation
##              *inside* the helper function, so that we can use the normalizing constant
##              computed by Runuran instead of doing another "integrate" call.
## 06/01/2010   add postprocessing of the coefficients samples
## 16/02/2010   correct title of getLogMargLikEstimate man page
## 17/02/2010   split off getMarginalZ into separate code file
## 18/02/2010   split off getLogMargLikEstimate into separate code file
## 15/03/2010   add check for class of mcmc argument ...
## 17/03/2010   ... but do it correctly (the class is called McmcOptions and not Mcmc)
## 08/04/2010   Add description of the return list (S3 class "GlmBayesMfpSamples").
## 17/05/2010   Add "useOpenMP" option, which makes it easier
##              to switch than setting the environment variable OMP_NUM_THREADS
##              (especially when using R on the server via Emacs Tramp...)
## 24/05/2010   return samples on the response scale ("response") instead of their
##              averages ("fitted"), because this averaging can better be done in
##              a "fitted" method and we need the raw samples in sampleBma.R
## 25/05/2010   different structure of return list;
##              layout of bfp and uc samples is now nPar x nSamples.
## 28/05/2010   - remove argument "weights" which is no longer needed here,
##              as we only sample the linear predictors for new observations.
##              - rename "response" to "fitted", which shall also contain the
##              *linear predictors* for the fitted data (and not the *means*).
## 02/07/2010   extend the functionality to the case with fixed z (option "fixedZ")
## 08/07/2010   check if the models were fit by empirical Bayes. In that
##              case use the fixed z option !
## 26/07/2010   Do not drop dimensions when selecting UC coefficients samples
## 23/11/2012   modifications to accommodate the TBF methodology
## 03/12/2012   modifications to accommodate the Cox models
## 24/01/2013   adapt for fixedg option
## 03/07/2013   comment on offsets
#####################################################################################

##' @include helpers.R
##' @include McmcOptions-class.R
##' @include McmcOptions-methods.R
##' @include GlmBayesMfpSamples-class.R
##' @include getMarginalZ.R
##' @include getLogMargLikEstimate.R
NULL

##' Produce posterior samples from one GLM / Cox model
##'
##' Based on the result list from \code{\link{glmBayesMfp}}, for the first model
##' in the list MCMC samples are produced. In parallel to the sampling of
##' coefficients and FP curve points, optionally the marginal likelihood of the
##' model is estimated with MCMC samples. This provides a check of the
##' integrated Laplace approximation used in the model sampling. If TBF
##' methodology is used, then no MCMC is necessary, instead ordinary Monte Carlo
##' samples from an approximate posterior distribution are obtained.
##'
##' @param object the \code{GlmBayesMfp} object, from which only the first model
##' will be processed (at least for now \ldots)
##' @param mcmc MCMC options object with class \code{\linkS4class{McmcOptions}}.
##' If TBF is used, each sample is accepted, and the number of samples is given
##' by \code{\link{sampleSize}}(\code{mcmc}).
##' @param estimateMargLik shall the marginal likelihood be estimated in
##' parallel? (default) Only has an effect if full Bayes and not TBF is used.
##' @param gridList optional list of appropriately named grid vectors for FP
##' evaluation. Default is length (\code{gridSize} - 2) grid per covariate
##' additional to the observed values (two are at the endpoints)
##' @param gridSize see above (default: 203)
##' @param newdata new covariate data.frame with exactly the names (and
##' preferably ranges) as before (default: no new covariate data) Note that
##' there is no option for offsets for new data at the moment. Just add the
##' offsets to the \code{predictions} slot of \code{samples} in the return list
##' yourself.
##' @param fixedZ either \code{NULL} (default) or a (single) fixed z value to
##' be used, in order to sample from the conditional posterior given this z.
##' If \code{object} was constructed by the empirical Bayes machinery,
##' this will default to the estimated z with maximum conditional marginal
##' likelihood. If \code{object} was constructed with the option \code{fixedg},
##' then the fixed value will be used by default.
##' @param marginalZApprox method for approximating the marginal density of the
##' log covariance factor z, see \code{\link{getMarginalZ}} for the details
##' (default: same preference list as in \code{\link{getMarginalZ}})
##' If TBF are used in conjunction with incomplete inverse gamma hyperprior on
##' g = exp(z), then the posterior distribution of g is again of this form.
##' Therefore this option does not have any effect in that case, because the
##' samples are directly obtained from that posterior distribution.
##' @param verbose should information on computation progress be given?
##' (default)
##' @param debug print debugging information? (not default)
##' @param useOpenMP shall OpenMP be used to accelerate the computations?
##' (default)
##' @param correctedCenter If TRUE predict new data based on the centering
##' of the original data.
##'
##' @return Returns a list with the following elements:
##' \describe{
##' \item{samples}{an object of S4 class
##' \code{\linkS4class{GlmBayesMfpSamples}}}
##' \item{coefficients}{samples of all original coefficients in the model
##' (nCoefs x nSamples)}
##' \item{acceptanceRatio}{proportion of accepted Metropolis-Hastings proposals}
##' \item{logMargLik}{if \code{estimateMargLik} is \code{TRUE}, this list is
##' included: it contains the elements \code{numeratorTerms} and
##' \code{denominatorTerms} for the numerator and denominator samples of the
##' Chib Jeliazkov marginal likelihood estimate,
##' \code{highDensityPointLogUnPosterior} is the log unnormalized posterior
##' density at the fixed parameter and the resulting \code{estimate} and
##' \code{standardError}.}
##' }
##'
##' @importFrom Rcpp evalCpp
##'
##' @export
##' @keywords models regression
sampleGlm <-
  function(object,
           mcmc = McmcOptions(),
           estimateMargLik = TRUE,
           gridList = list(),
           gridSize = 203L,
           newdata = NULL,
           fixedZ = NULL,
           marginalZApprox = NULL,
           verbose = TRUE,
           debug = FALSE,
           useOpenMP = TRUE,
           correctedCenter = FALSE) {
    ## check the object
    if (!inherits(object, "GlmBayesMfp")) {
      stop(simpleError("object must be of class GlmBayesMfp"))
    }
    if (!(length(object) >= 1L)) {
      stop(simpleError("there has to be at least one model in the object"))
    }

    ## other checks
    stopifnot(
      is.bool(estimateMargLik),
      is.bool(verbose),
      is.bool(debug),
      is(mcmc, "McmcOptions"),
      is.bool(useOpenMP)
    )

    ## coerce newdata to data frame
    newdata <- as.data.frame(newdata)
    nNewObs <- nrow(newdata)

    ## ## covariates matrix for newdata (if there is any):
    ## newX <-
    ##     if(nNewObs > 0L)
    ##     {
    ##         constructNewdataMatrix(object=object,
    ##                                newdata=newdata)
    ##     }
    ##     else
    ##         NULL

    ## get the old attributes of the object
    attrs <- attributes(object)

    ## is this a GLM or a Cox model?
    doGlm <- attrs$distribution$doGlm

    ## take only the first model
    model <- object[[1L]]
    config <- model$configuration
    info <- model$information

    ## get the (centered) design matrix of the model for the original data
    design <- getDesignMatrix(
      modelConfig = config,
      object = object,
      intercept = doGlm
    )
    ## the model dimension (including the intercept for GLMs)
    modelDim <- ncol(design)

    ## check if the model is the null model
    isNullModel <- identical(
      modelDim,
      ifelse(doGlm, 1L, 0L)
    )

    ## check / modify the fixedZ option
    if (is.null(fixedZ)) {
      if (isNullModel) {
        fixedZ <- 0
      } else if (attrs$searchConfig$useFixedg || attrs$searchConfig$empiricalBayes) {
        fixedZ <- info$zMode
      }
    }

    if (useFixedZ <- !is.null(fixedZ)) {
      stopifnot(
        is.numeric(fixedZ),
        is.finite(fixedZ),
        identical(length(fixedZ), 1L)
      )
    } else {
      fixedZ <- 0
    }

    ## extract TBF and g-prior info
    tbf <- attrs$distribution$tbf
    gPrior <- attrs$distribution$gPrior

    ## correct estimateMargLik option
    estimateMargLik <- estimateMargLik && (!tbf)

    ## correct MCMC option
    if (tbf) {
      mcmc <- McmcOptions(
        burnin = 0L,
        step = 1L,
        samples = sampleSize(mcmc)
      )
    }

    ## compute the selected approximation to the marginal z posterior,
    ## including the log density and the random number generator for it
    marginalz <-
      if (useFixedZ) {
        ## this is for the special case with a fixed z
        list(
          logDens = function(z) ifelse(z == fixedZ, 0, -Inf),
          gen = function(n = 1) rep.int(fixedZ, n)
        )
      } else {
        if (tbf && is(gPrior, "IncInvGammaGPrior")) {
          ## analytical solution possible in this case!
          ## compute posterior parameters of IncIG:
          a <- gPrior@a + (modelDim - 1) / 2
          b <- gPrior@b + info$residualDeviance / 2

          list(
            logDens = function(z) {
              logNormConst <- ifelse(
                b > 0,
                a * log(b) - pgamma(b, a, log.p = TRUE) - lgamma(a),
                log(a)
              )
              logNormConst - (a + 1) * log1p(exp(z)) - b / (1 + exp(z)) + z
            },
            gen = function(n = 1) {
              p <- runif(n = n)

              ret <-
                if (b > 0) {
                  b / qgamma(p = (1 - p) * pgamma(b, a), shape = a) - 1
                } else {
                  (1 - p)^(-1 / a) - 1
                }
              return(ret)
            }
          )
        } else {
          ## the usual way:
          getMarginalZ(info,
            method = marginalZApprox,
            verbose = verbose
          )
        }
      }

    ## pack the info in handy lists:

    ## pack the options
    options <- list(
      mcmc = mcmc,
      estimateMargLik = estimateMargLik,
      verbose = verbose,
      debug = debug,
      isNullModel = isNullModel,
      useFixedZ = useFixedZ,
      fixedZ = as.double(fixedZ),
      useOpenMP = useOpenMP
    )

    ## start the progress bar (is continued in the C++ code)
    if (verbose) {
      cat("0%", rep("_", 100 - 6), "100%\n", sep = "")
    }

    ## then call C++ to do the rest:
    cppResults <- cpp_sampleGlm(
      model,
      attrs$data,
      attrs$fpInfos,
      attrs$ucInfos,
      attrs$fixInfos,
      attrs$distribution,
      attrs$searchConfig,
      options,
      marginalz
    )

    ## start return list
    results <- list()

    ## add info on tbf
    results$tbf <- tbf

    ## compute acceptance ratio
    results$acceptanceRatio <-
      if (tbf) {
        1
      } else {
        ## we do Monte Carlo in the TBF case!
        cppResults$nAccepted / mcmc@iterations
      }

    ## are we again verbose?
    if (verbose) {
      if (tbf) {
        cat("\nFinished MC simulation from approximate parameter posterior\n")
      } else {
        cat(
          "\nFinished MCMC simulation with acceptance ratio",
          round(results$acceptanceRatio, 3),
          "\n"
        )
      }
    }

    ## compute log marginal likelihood estimate (which is only defined up to a constant, so
    ## it can only be used for model ranking (?))
    if (estimateMargLik) {
      results$logMargLik <-
        with(
          cppResults,
          getLogMargLikEstimate(
            numeratorTerms = samples$margLikNumerator,
            denominatorTerms = samples$margLikDenominator,
            highDensityPointLogUnPosterior = highDensityPointLogUnPosterior
          )
        )

      ## append original things
      results$logMargLik <-
        c(
          results$logMargLik,
          list(
            numeratorTerms = cppResults$samples$margLikNumerator,
            denominatorTerms = cppResults$samples$margLikDenominator,
            highDensityPointLogUnPosterior = cppResults$highDensityPointLogUnPosterior
          )
        )
    }


    ## start post-processing.

    ## abbreviation for the coefficients sample matrix (nCoefs x nSamples)
    simCoefs <-
      results$coefficients <- cppResults$samples$coefficients


    ## so the number of samples is:
    nSamples <- ncol(simCoefs)

    ## the linear predictor samples for the fitted data:
    fitted <- design %*% simCoefs

    # give some names

    rownames(results$coefficients) <- colnames(design)
    if (doGlm) rownames(results$coefficients)[1] <- "(Intercept)"

    ## samples from the predictive distribution for new data,
    ## if this is required
    predictions <-
      if (nNewObs) {
        ## get new data matrix
        tempX <- constructNewdataMatrix(
          object = object,
          newdata = newdata
        )

        ## copy old GlmBayesMfp object
        tempObj <- object

        ## correct model matrix in tempMod to new data matrix
        attr(tempObj, "data") <-
          list(
            x = tempX,
            xCentered = scale(tempX, center = TRUE, scale = FALSE)
          )

        if (correctedCenter == FALSE) {
          ## so we can get the design matrix
          newDesign <- getDesignMatrix(
            modelConfig = config,
            object = tempObj,
            intercept = doGlm
          )

          ## so the linear predictor samples are
          linPredSamples <- newDesign %*% simCoefs
        } else if (correctedCenter == TRUE) {
          newDesignUC <- getDesignMatrix(
            modelConfig = config,
            object = tempObj,
            intercept = doGlm,
            center = FALSE
          )

          oldDesignUC <- getDesignMatrix(
            modelConfig = config,
            object = object,
            intercept = doGlm,
            center = FALSE
          )

          oldMeans <- colMeans(oldDesignUC)

          start <- ifelse(doGlm, 2, 1) # If there is an intercept we don't want to subtract mean
          for (k in start:length(oldMeans)) {
            newDesignUC[, k] <- newDesignUC[, k] - oldMeans[k]
          }

          ## so the linear predictor samples are
          linPredSamples <- newDesignUC %*% simCoefs
        }

        linPredSamples
      } else {
        ## no prediction required.
        ## But we return an empty matrix because that is expected
        ## by the GlmBayesMfpSamples class!
        matrix(
          nrow = 0L,
          ncol = 0L
        )
      }

    ## process all coefficients samples: fixed, FP, UC in this order.

    ## now we need the colnames of the design matrix:
    colNames <- colnames(attr(object, "data")$x)


    ## invariant: already coefCounter coefficients samples (rows of simCoefs) processed
    coefCounter <- 0L

    ## the fixed covariate (and intercept samples)
    fixCoefs <- list()

    if (doGlm) {
      fixName <- attrs$termNames$fixed[1]
      mat <- simCoefs[1, ,
        drop = FALSE
      ]
      coefCounter <- coefCounter + 1

      ## and also get the names
      rownames(mat) <- colNames[1]

      ## and this is located in the list
      fixCoefs[[fixName]] <- mat
    }

    ## start processing all fixed terms
    for (i in seq_along(fixList <- attrs$indices$fixed)) {
      ## get the name of the fixed term
      fixName <- attrs$termNames$fixed[i + doGlm]

      ## check if this fixed covariate is included in the model
      if (i %in% config$fixTerms) {
        ## then we get the corresponding samples
        mat <- simCoefs[
          coefCounter +
            seq_len(len <- length(fixList[[i]])), ,
          drop = FALSE
        ]

        ## correct invariant
        coefCounter <- coefCounter + len

        ## and also get the names
        rownames(mat) <- colNames[fixList[[i]]]

        ## and this is located in the list
        fixCoefs[[fixName]] <- mat
      }
    }


    ## samples of fractional polynomial function values evaluated at grids will
    ## be elements of this list:
    bfpCurves <- list()
    ## Note that only those bfp terms are included which also appear in the
    ## model configuration.

    ## start processing all FP terms
    for (i in seq_along(attrs$indices$bfp)) {
      ## what is the name of this FP term?
      fpName <- attrs$termNames$bfp[i]

      ## the powers for this FP term
      p.i <- config$powers[[fpName]]

      ## if there is at least one power for this FP, we add a list element, else not.
      if ((len <- length(p.i)) > 0) {
        ## determine additional grid values:
        obs <- attrs$data$x[, attrs$indices$bfp[i], drop = FALSE]

        ## if there is no grid in gridList, we take an additional scaled grid using the gridSize argument
        if (is.null(g <- gridList[[fpName]])) {
          g <- seq(
            from = min(obs),
            to = max(obs),
            length = gridSize
          )
        }

        ## the resulting total grid is:
        g <- union(obs, g)
        gridSizeTotal <- length(g)

        ## sort the grid
        g <- sort(g)

        ## and rearrange as column with name (needed for getFpTransforms)
        g <- matrix(g,
          nrow = gridSizeTotal,
          ncol = 1L,
          dimnames = list(NULL, fpName)
        )

        ## the part of the design matrix corresponding to the grid
        xMat <- getFpTransforms(g, p.i, center = TRUE)

        ## multiply that with the corresponding coefficients to get the FP curve samples
        mat <- xMat %*% simCoefs[coefCounter + seq_len(len), , drop = FALSE]

        ## correct invariant
        coefCounter <- coefCounter + len

        ## save the grid as an attribute of the samples
        attr(mat, "scaledGrid") <- g

        ## save position of observed values
        attr(mat, "whereObsVals") <- match(obs, g)

        ## then write into list
        bfpCurves[[fpName]] <- mat
      }
    }

    ## uncertain fixed form covariates coefficients samples
    ## will be elements of this list:
    ucCoefs <- list()
    ## Note that only those UC terms are included which also appear in the model
    ## configuration.


    ## start processing all UC terms
    for (i in seq_along(ucList <- attrs$indices$ucList)) {
      ## get the name of the UC term
      ucName <- attrs$termNames$uc[i]

      ## check if this UC is included in the model
      if (i %in% config$ucTerms) {
        ## then we get the corresponding samples
        mat <- simCoefs[
          coefCounter +
            seq_len(len <- length(ucList[[i]])), ,
          drop = FALSE
        ]

        ## correct invariant
        coefCounter <- coefCounter + len

        ## and also get the names
        rownames(mat) <- colNames[ucList[[i]]]

        ## and this is located in the list
        ucCoefs[[ucName]] <- mat
      }
    }

    ## collect processed samples into S4 class object
    results$samples <- new("GlmBayesMfpSamples",
      fitted = fitted,
      predictions = predictions,
      fixCoefs = fixCoefs,
      z = cppResults$samples$z,
      bfpCurves = bfpCurves,
      ucCoefs = ucCoefs,
      shiftScaleMax = attrs$shiftScaleMax,
      nSamples = nSamples
    )

    ## finished post-processing.

    ## finally return the whole stuff.
    return(results)
  }

#####################################################################################
## Author: Isaac Gravestock [isaac *.* gravestock *a*t* uzh *.* ch]
## Project: BFPs for GLMs
##
## Description:
## Construct a Survival model formula based on a glmBfp object
##
## History:
## 14/07/2015 Copied from CoxTBFs project functions-funsel-2.bma.R
#####################################################################################
NULL

##' Construct a survival formula based on a glmBfp object with censInd not null.
##'
##' This is an internal function to construct a survival formula based on a glmBfp object
##' with censInd not null.
##'
##' @param models.listpart the glmBfp object for which to construct the survival formula
##' @param time.var the name of the time variable as character string
##' @param status.var the name of the censoring indicator variable as character string
##' @return The formula object based on the glmBfp object.
##'
##' @keywords internal utilities

writeFormula <- function(models.listpart, time.var, status.var) {
  surv.part <- paste("survival::Surv(", time.var, ", ", status.var, ") ~ ", sep = "")

  # extract linear terms
  fix.parts <- models.listpart[[1]]$configuration$fixTerms
  fix.names <- attributes(models.listpart)$termNames$fix

  uc.parts <- models.listpart[[1]]$configuration$ucTerms
  uc.names <- attributes(models.listpart)$termNames$uc

  shift <- attributes(models.listpart)$shiftScaleMax[, 1]
  scale <- attributes(models.listpart)$shiftScaleMax[, 2]

  if (length(models.listpart[[1]]$configuration$powers) > 0) {
    # extract powers for terms which should have transformations
    powers <- models.listpart[[1]]$configuration$powers
    bfp.trans <- vector("character")
    for (i in seq_along(powers)) {
      this.term <- ""
      if (length(powers[[i]]) > 0) {
        this.name <- names(powers[i])
        this.power <- paste("c(", paste(powers[[i]], collapse = ",", sep = ""), ")", sep = "")
        this.term <- paste("fpTrans(", this.name, ",", this.power, sep = "")

        if (scale[i] != 0) {
          this.term <- paste(this.term, ", ", scale[i], sep = "")
        }

        if (shift[i] != 0) {
          this.term <- paste(this.term, ", ", shift[i], sep = "")
        }

        this.term <- paste(this.term, ")", sep = "")
      }
      if (this.term != "") bfp.trans <- c(bfp.trans, this.term)
    }
    v <- paste(c(uc.names[uc.parts], bfp.trans, fix.names[fix.parts]), collapse = " + ")
    return(formula(paste(surv.part, v)))
  }

  # when there are no transformed variables
  v <- paste(c(uc.names[uc.parts], fix.names[fix.parts]), collapse = " + ")
  return(formula(paste(surv.part, v)))
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian fractional polynomials
##
## Time-stamp: <[testCox.R] by DSB Mit 03/07/2013 22:58 (CEST)>
##
## Description:
## R code and interface to C++ code that could be used for the Cox model
## computations, for regression testing purposes.
##
## History:
## 29/11/2012   file creation
## 03/12/2012   make it internal
## 03/07/2013   add offsets
#####################################################################################

##' @include helpers.R
NULL


##' Test the Cox model computation for the TBF approach
##'
##' @param survTimes the survival times
##' @param censInd the logical censoring indicator (\code{TRUE} = observed,
##' \code{FALSE} = censored survival times)
##' @param offsets known component to be included in the linear predictor during
##' fitting. This must be a numeric vector of length equal to the number of
##' cases (if not provided, a vector of zeroes)
##' @param X the design matrix, *without* the intercept 1's!, with at least one
##' column
##' @param useCppCode use the C++ code? (default) otherwise the R-function
##' \code{\link{coxph}} is used
##' @return a list with the coefficient estimates (\code{betas}), the covariance
##' matrix estimate (\code{cov}) and the residual deviance (\code{deviance}).
##'
##' @keywords utilities internal
##' @importFrom survival coxph
##' @author Daniel Sabanes Bove
testCox <- function(survTimes,
                    censInd,
                    offsets = rep.int(0, length(survTimes)),
                    X,
                    useCppCode = FALSE) {
  ## checks
  stopifnot(
    is.numeric(survTimes),
    is.logical(censInd),
    is.matrix(X),
    identical(length(survTimes), length(censInd)),
    identical(length(survTimes), length(offsets)),
    identical(length(survTimes), nrow(X)),
    is.bool(useCppCode)
  )

  ## summaries
  nObs <- nrow(X)
  nCovs <- ncol(X)

  ## check that we have at least one covariate
  ## (null model is not treated here)
  stopifnot(nCovs > 0)

  ## method for handling ties:
  method <- "efron"

  ## now do either simple R or go C++
  if (useCppCode) {
    ## sort according to survival times
    sorted <- order(survTimes)
    survTimes <- survTimes[sorted]
    censInd <- censInd[sorted]
    X <- X[sorted, ]

    ## go C++ for fitting the Cox model
    storage.mode(X) <- "double"
    tmp <- cpp_coxfit(
      as.double(survTimes),
      as.integer(censInd),
      as.double(offsets),
      X,
      ifelse(method == "efron", 1L, 0L)
    )

    ## get results
    deviance <- -2 * (tmp$loglik[1] - tmp$loglik[2])
    covMat <- tmp$imat
    betas <- tmp$coef
  } else {
    ## fit the Cox model
    tmp <- survival::coxph(Surv(survTimes, censInd) ~ X + offset(offsets), ties = method)

    ## get results
    deviance <- -2 * (tmp$loglik[1] - tmp$loglik[2])
    covMat <- tmp$var
    betas <- tmp$coefficients
  }

  ## return the results
  return(list(
    betas = betas,
    cov = covMat,
    deviance = deviance
  ))
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[GlmBayesMfpSamples-methods.R] by DSB Mon 03/12/2012 18:18 (CET)>
##
## Description:
## Additional convenience methods for GlmBayesMfpSamples class objects.
##
## History:
## 03/08/2010   file creation with a subset method
#####################################################################################

##' Subset method for GlmBayesMfpSamples objects
##'
##' Index the samples to select a subset of samples.
##'
##' @name GlmBayesMfpSamples-subsetting
##' @aliases [,GlmBayesMfpSamples,ANY,missing,missing-method
##'
##' @usage \S4method{[}{GlmBayesMfpSamples,ANY,missing,missing}(x, i)
##' @param x the \code{\linkS4class{GlmBayesMfpSamples}} object
##' @param i the vector defining the subset of samples
##' @return The subset of the same class.
##' @note The function call will fail if any of the saved bfpCurves or ucCoefs
##' does not have enough samples to be subset by \code{i} !
##'
##' @seealso \code{\linkS4class{GlmBayesMfpSamples}}
##' @keywords methods
##' @exportMethod "["
setMethod("[",
  signature = signature(
    x = "GlmBayesMfpSamples",
    i = "ANY",
    j = "missing",
    drop = "missing"
  ),
  def = function(x, i) {
    x@fitted <- x@fitted[, i, drop = FALSE]

    if (length(x@predictions)) {
      x@predictions <- x@predictions[, i, drop = FALSE]
    }

    fixCoefs <- x@fixCoefs
    for (p in names(fixCoefs)) {
      fixCoefs[[p]] <- fixCoefs[[p]][, i, drop = FALSE]
    }
    x@fixCoefs <- fixCoefs


    x@z <- x@z[i]

    bfpCurves <- x@bfpCurves
    for (p in names(bfpCurves)) {
      ## save attributes
      sg <- attr(bfpCurves[[p]], "scaledGrid")
      wov <- attr(bfpCurves[[p]], "whereObsVals")

      bfpCurves[[p]] <- bfpCurves[[p]][, i, drop = FALSE]

      ## get back the attributes
      attr(bfpCurves[[p]], "scaledGrid") <- sg
      attr(bfpCurves[[p]], "whereObsVals") <- wov
    }
    x@bfpCurves <- bfpCurves

    ucCoefs <- x@ucCoefs
    for (p in names(ucCoefs)) {
      ucCoefs[[p]] <- ucCoefs[[p]][, i, drop = FALSE]
    }
    x@ucCoefs <- ucCoefs

    x@nSamples <- length(x@fixCoefs[[1]])

    return(x)
  }
)

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs.
##
## Time-stamp: <[inclusionProbs.R] by DSB Die 01/12/2009 13:21 (CET)>
##
## Description:
## Compute (model averaged) posterior inclusion probabilities for the uncertain
## variables (including FP variables) based on a GlmBayesMfp object.
##
## History:
## 01/12/2009   modify from the bfp package, and add roxygen tags.
#####################################################################################

##' Compute posterior inclusion probabilities based on GlmBayesMfp object
##'
##' Compute (model averaged) posterior inclusion probabilities for the uncertain
##' variables (including FP variables) based on a GlmBayesMfp object.
##'
##' @param GlmBayesMfpObject the GlmBayesMfp object
##' @param postProbs the vector of posterior model probabilities, defaults to
##' the normalized probabilities in \code{GlmBayesMfpObject}
##' @return the resulting inclusion probabilities vector
##'
##' @export
##' @keywords utilities
inclusionProbs <- function(GlmBayesMfpObject,
                           postProbs =
                             posteriors(GlmBayesMfpObject,
                               type = "normalized"
                             )) {
  postProbs <- postProbs / sum(postProbs)
  inds <- attr(GlmBayesMfpObject, "indices")
  termNames <- attr(GlmBayesMfpObject, "termNames")

  nams <- unlist(termNames[c("bfp", "uc")])
  ret <- numeric(length(nams))
  names(ret) <- nams

  i <- 0

  for (j in seq_along(inds$bfp)) {
    i <- i + 1
    present <- sapply(GlmBayesMfpObject, function(one) as.logical(length(one$configuration$powers[[j]])))
    ret[i] <- sum(present * postProbs)
  }

  for (j in seq_along(inds$ucList)) {
    i <- i + 1
    present <- sapply(GlmBayesMfpObject, function(one) any(j == one$configuration$ucTerms))
    ret[i] <- sum(present * postProbs)
  }

  return(ret)
}

## ****************************************************************************************************

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs
##
## Time-stamp: <[getLogMargLikEstimate.R] by DSB Mon 05/07/2010 13:36 (CEST)>
##
## Description:
## Compute the Chib-Jeliazkov log marginal likelihood estimate from the MCMC output
##
## History:
## 18/02/2010   separate code file;
##              correct bug for computing Omega(0): head(index, -0L) always gives
##              a length zero vector instead of the whole "index"!!!
#####################################################################################



##' Compute the Chib-Jeliazkov log marginal likelihood estimate from the MCMC output
##'
##' @param numeratorTerms terms for the sum in the numerator of the posterior density ordinate
##' estimate at the high density point
##' @param denominatorTerms terms for the sum in the denominator of the posterior density ordinate
##' estimate at the high density point
##' @param highDensityPointLogUnPosterior log unnormalized posterior (i.e. likelihood times prior)
##' of the high density point
##' @param endLag up to which lag should the covariance incorporate the uncertainty? (default: 40)
##' @return list with resulting \dQuote{estimate} and \dQuote{standardError}.
##'
##' @keywords internal
##'
##' @importFrom utils head tail
getLogMargLikEstimate <- function(numeratorTerms,
                                  denominatorTerms,
                                  highDensityPointLogUnPosterior,
                                  endLag = 40L) {
  ## note that here it is assumed that there are equally many numerator and
  ## denominator numbers, therefore
  stopifnot(
    identical(
      length(numeratorTerms),
      length(denominatorTerms)
    ),
    is.double(numeratorTerms),
    is.double(denominatorTerms),
    is.double(highDensityPointLogUnPosterior)
  )

  ## first combine each numerator term with corresponding denominator term
  h <- rbind(
    numeratorTerms,
    denominatorTerms
  )

  ## the estimate for that is
  hHat <- rowMeans(h)

  ## so the estimate for the log posterior density ordinate is:
  logPosteriorDensityEstimate <- log(hHat[1]) - log(hHat[2])

  ## then compute the standard error for this estimate:
  hDiffHat <- h - hHat

  B <- ncol(hDiffHat)
  index <- seq_len(B)

  ## function to compute the autocovariance estimate for a given lag
  getOmega <- function(lag) {
    ## get index for head part of time series
    headIndex <-
      if (identical(lag, 0L)) {
        index
      } else {
        head(index, -lag)
      }

    ## and for tail
    tailIndex <-
      if (identical(lag, 0L)) {
        index
      } else {
        tail(index, -lag)
      }

    ## now build up result
    ret <- matrix(
      data = 0,
      nrow = 2L,
      ncol = 2L
    )

    for (l in seq_len(B - lag)) {
      ret <- ret + tcrossprod(
        hDiffHat[, tailIndex[l]],
        hDiffHat[, headIndex[l]]
      ) / B
    }
    return(ret)
  }

  ## start with Omega_0
  covMat <- getOmega(0L) / B

  ## then add other terms
  for (s in seq_len(endLag)) {
    thisOmega <- getOmega(s)
    covMat <- covMat + (1 - s / (endLag + 1)) * (thisOmega + t(thisOmega)) / B
  }

  ## now covMat is ready to get delta ruled:
  aHat <- c(1 / hHat[1], -1 / hHat[2])
  se <- sqrt(t(aHat) %*% covMat %*% aHat)

  ## return a list with the log marg lik estimate and the standard error
  return(list(
    estimate = highDensityPointLogUnPosterior - logPosteriorDensityEstimate,
    standardError = se
  ))
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs
##
## Time-stamp: <[fpScale.R] by DSB Die 16/02/2010 13:12 (CET)>
##
## Description:
## Scale an FP term variable appropriately before model search using "fpScale".
##
## History:
## 04/07/2008   copy from thesis function collection.
## 18/11/2009   document with Roxygen
#####################################################################################

##' Shift and scale a covariate vector (if wished) to have positive and small numbers.
##'
##' This function is (almost exactly) copied from package \dQuote{mfp} to be consistent.
##'
##' @param x the covariate vector
##' @param scaling should shifting and scaling be performed (default)?
##'
##' @return list of \sQuote{shift} and \sQuote{scale} parameters appropriate for this
##' covariate vector.
##'
##' @keywords internal
fpScale <- function(x, scaling = TRUE) {
  scale <- 1
  shift <- 0

  ## check scaling argument
  stopifnot(is.bool(scaling))

  if (isTRUE(scaling)) {
    if (min(x) <= 0) {
      z <- diff(sort(x))
      shift <- min(z[z > 0]) - min(x)
      shift <- ceiling(shift * 10) / 10
    }
    range <- mean(x + shift)
    scale <- 10^(sign(log10(range)) * round(abs(log10(range))))
  }
  return(list(shift = shift, scale = scale))
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian fractional polynomials for GLMs
##
## Time-stamp: <[optimize.R] by DSB Die 25/05/2010 16:20 (CEST)>
##
## Description:
## R code and interface to C++ code that could be used for the marginal likelihood
## approximation, for regression testing purposes.
##
## History:
## 08/12/2009   file creation
## 09/12/2009   add a wrapper which uses both cppOptimize and cppScalarBfgs
##              to reduce the number of iterations and get a good hessian at the
##              minimum
## 15/02/2010   Note that optimBfgs does not work well!
## 25/05/2010   remove the function which uses both optimize and bfgs;
##              move the bfgs interface to this file and rename it to "cppBfgs";
##              add roxygen doc
#####################################################################################


##' Interface to the internal C++ optimization routine "bfgs"
##'
##' @param x0 the start value
##' @param f_ the target function
##' @param min.x minimum bound on x (default \code{-Inf})
##' @param max.x maximum bound on x (default \code{+Inf})
##' @param prec precision (default \code{1e-5})
##' @param verbose be verbose? (not default)
##' @return A list with the following elements:
##' \describe{
##' \item{par}{the minimum abscissa found by the algorithm}
##' \item{inv.hessian}{the inverse Hessian at \code{par}}
##' \item{evaluations}{list of the function evaluation pairs: \code{args} and
##' \code{vals}}
##' \item{code}{the convergence code. 0 is \dQuote{OK}, -1 is \dQuote{lost
##' precision}, and +1 is \dQuote{change not large enough}}
##' }
##'
##' @keywords utilities internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
cppBfgs <- function(x0,
                    f_,
                    min.x = c(-Inf),
                    max.x = c(+Inf),
                    prec = 1e-5,
                    verbose = FALSE) {
  return(cpp_bfgs(
    as.double(x0),
    f_,
    as.double(min.x),
    as.double(max.x),
    as.double(prec),
    verbose
  ))
}



##' Interface to the internal C++ optimization routine "optimize"
##'
##' @param f_ the function
##' @param min.x  minimum bound on x
##' @param max.x maximum bound on x
##' @param prec precision (same default as for the original optimize function)
##' @return A list with the following elements:
##' \describe{
##' \item{par}{the minimum abscissa found by the algorithm}
##' \item{inv.hessian}{the inverse Hessian at \code{par}}
##' \item{evaluations}{list of the function evaluation pairs: \code{args} and
##' \code{vals}}
##' }
##'
##' @keywords utilities internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
cppOptimize <- function(f_,
                        min.x,
                        max.x,
                        prec = .Machine$double.eps^0.25) {
  return(cpp_optimize(
    f_,
    as.double(min.x),
    as.double(max.x),
    as.double(prec)
  ))
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs
##
## Time-stamp: <[computeModels.R] by DSB Don 08/04/2010 13:48 (CEST)>
##
## Description:
## Compute model information (including the log marginal likelihood)
## for a given list of model configurations and glmBayesMfp output.
##
## History:
## 16/02/2010   file creation
## 08/04/2010   attribute writing works as intended.
#####################################################################################

##' @include helpers.R
NULL

##' Compute model information for a given list of model configurations and glmBayesMfp output.
##'
##' If we want to compute the marginal likelihood and information necessary for
##' generating posterior samples for new models not encountered in the model search
##' done by \code{\link{glmBayesMfp}}, this function can be used: Provide it with the
##' models \code{configurations} to be interpreted in the context of the \code{object}
##' of class \code{\link{GlmBayesMfp}}. The result is again of the latter class, but contains
##' only the new models (similarly as the whole model space would consist of these and an
##' exhaustive search would have been conducted).
##'
##' @param configurations list of the model configurations
##' @param object the \code{\link{GlmBayesMfp}} object
##' @param verbose be verbose? (default: only for more than 100 configurations)
##' @param debug be even more verbose and echo debug-level information? (not by default)
##' @return The \code{\link{GlmBayesMfp}} object with the new models. This can directly
##' be used as input for \code{\link{sampleGlm}}.
##'
##' @export
##' @keywords models regression
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
computeModels <- function(configurations,
                          object,
                          verbose = length(configurations) > 100L,
                          debug = FALSE) {
  ## checks
  stopifnot(
    is.list(configurations),
    inherits(object, "GlmBayesMfp"),
    is.bool(verbose),
    is.bool(debug)
  )

  ## get all attributes of the
  attrs <- attributes(object)

  ## include the logicals
  attrs$options$verbose <- verbose
  attrs$options$debug <- debug

  ## update the searchConfig argument to include the model configuration etc.
  ## so that the C++ side knows what to do!

  ## we do an "exhaustive" approach - only evaluate one model.
  ## So the C++ function glmExhaustive has the responsibility to
  ## handle this case.
  attrs$searchConfig$doSampling <- FALSE

  ## and these are the model configurations
  attrs$searchConfig$modelConfigs <- configurations

  ## then go C++
  result <- cpp_glmBayesMfp(
    attrs$data,
    attrs$fpInfos,
    attrs$ucInfos,
    attrs$fixInfos,
    attrs$searchConfig,
    attrs$distribution,
    attrs$options
  )

  ## C++ attaches the following attributes:

  ## numVisited
  ## inclusionProbs
  ## logNormConst

  ## we again just modify some of the attributes of the old object
  attrs$numVisited <- attr(result, "numVisited")
  attrs$inclusionProbs[] <- attr(result, "inclusionProbs")
  attrs$logNormConst <- attr(result, "logNormConst")
  attrs$names <- seq_along(result)

  ## so we can save much paperwork:
  attributes(result) <- attrs

  ## finally return the results
  return(result)
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[formula.R] by DSB Fre 15/06/2012 16:04 (CEST)>
##
## Description:
## Helper functions for formula construction.
##
## History:
## 18/11/2009   file creation: extra file for this seems to be better.
##              Try to get one Rd file with rdname roclets (see make.Rd2.roclet documentation
##              in roxygen package)
## 15/06/2012   remove x documentation from uc so that it is not duplicate
#####################################################################################

##' Mark a covariate for transformation with fractional polynomials
##'
##' Using this function, you can mark a covariate for transformation with fractional polynomials
##' in the formula for \code{\link{glmBayesMfp}}.
##'
##' @param x the covariate name
##' @param max maximum degree for this FP
##' @param scale use pre-transformation shifting and scaling to avoid numerical problems?
##' @param rangeVals extra numbers if the shifting and scaling should consider values in this range
##'
##' @return name of the provided covariate, with the other function parameters as  attached attributes
##'
##' @keywords utilities
##' @export
##' @rdname formula
bfp <- function(x,
                max = 2,
                scale = TRUE,
                rangeVals = NULL) {
  x <- deparse(substitute(x))
  attr(x, "max") <- max
  attr(x, "scale") <- scale
  attr(x, "rangeVals") <- rangeVals
  x
}

## ****************************************************************************************************

##' Mark a covariate expression for joint variable selection
##'
##' Using this function, you can mark a covariate or a group of combined covariates for joint
##' variable selection (\dQuote{uncertain covariate fixed form covariate groups}) in the formula for
##' \code{\link{glmBayesMfp}}.
##'
##' @return Just the name of the provided covariate
##'
##' @keywords utilities
##' @export
##' @rdname formula
`uc` <- function(x) {
  x <- deparse(substitute(x))
  x
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs.
##
## Time-stamp: <[constructNewdataMatrix.R] by DSB Mit 06/01/2010 13:05 (CET)>
##
## Description:
## Internal function to construct the covariates matrix for new data based on the formula
## and scaling info in an existing GlmBayesMfp object, for passing it to prediction functions.
##
## History:
## 10/12/2009   copy and modify from bfp package
#####################################################################################

##' Construct the covariates matrix for new data based on an existing GlmBayesMfp object
##'
##' This is an internal function, which constructs a model matrix for new covariate
##' data, based on the formula and scaling info in an existing GlmBayesMfp object.
##' The matrix can then be passed to prediction functions.
##'
##' @param object a valid \code{\link{GlmBayesMfp}}-Object
##' @param newdata the new covariate data as a data.frame (with the same
##' covariate names as in the call to \code{\link{glmBayesMfp}})
##' @return The (uncentered!) model matrix with the FP columns shifted and scaled as for the
##' original data.
##'
##' @keywords internal utilities
constructNewdataMatrix <- function(object,
                                   newdata) {
  ## check class
  stopifnot(inherits(object, "GlmBayesMfp"))

  ## extract the covariates' formula and the names of the FP terms
  covariatesOnlyFormula <- attr(object, "formula")[-2]
  bfpTermNames <- attr(object, "termNames")$bfp

  ## get model matrix with the design variables for the new data
  newTerms <- terms(covariatesOnlyFormula, data = newdata)
  ret <- model.matrix(newTerms, data = newdata)

  ## extract the transformation parameters
  tr <- attr(object, "shiftScaleMax")

  ## and scale the new FP columns like for the old data
  for (bfp in bfpTermNames) {
    ## transform
    ret[, bfp] <- (ret[, bfp] + tr[bfp, "shift"]) / tr[bfp, "scale"]

    ## and afterwards check range: all transformed numbers must be positive!
    if (any(ret[, bfp] <= 0)) {
      stop(simpleError(paste("New data for covariate", bfp, "is out of range.")))
    }
  }

  ## return the correctly transformed model matrix
  return(ret)
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[evalZdensity.R] by DSB Fre 29/07/2011 15:13 (CEST)>
##
## Description:
## Evaluate the unnormalized marginal z density in a given model at a number of
## z values. This is mainly an exploratory function to test new optimization /
## integration strategies via the R interface.
##
## History:
## 16/05/2010   file creation: modified from the starting point sampleGlm.R
## 18/05/2010   modify the interface: now we accept one single model configuration
##              list, and a GlmBayesMfp object in which it is interpreted.
##              This is better since we do not depend on an already fitted
##              model.
## 08/07/2010   add an option to get the *conditional* marginal density
##              f(y | z) instead of the usual f(y, z) which is interpreted
##              as an unnormalized f(z | y).
## 29/07/2010   add the new option to get a better Laplace approximation in the
##              case of binary logistic regression.
## 29/07/2011   now "higherOrderCorrection"
#####################################################################################

##' @include helpers.R
NULL

##' Evaluate the (negative log) unnormalized marginal z density in a given
##' model.
##'
##' Based on the result list from \code{\link{glmBayesMfp}}, for the first model
##' in the list, the marginal z density can be evaluated.
##'
##' @param config the configuration of a single \code{GlmBayesMfp} model. The
##' null model is not allowed. It is interpreted in the context of
##' \code{object}.
##' @param object the \code{\link{GlmBayesMfp}} object
##' @param zValues the z values
##' @param conditional return the approximate *conditional* density f(y | z)?
##' (not default)
##' @param debug print debugging information? (not default)
##' @param higherOrderCorrection should a higher-order correction of the
##' Laplace approximation be used? (not default)
##'
##' @return the negative log marginal unnormalized density values at the
##' \code{zValues}. (Note the words \dQuote{negative}, \dQuote{log}, and
##' \dQuote{unnormalized} !!!)
##'
##' @keywords internal
##' @export
evalZdensity <-
  function(config,
           object,
           zValues,
           conditional = FALSE,
           debug = FALSE,
           higherOrderCorrection = FALSE) {
    ## check the object
    if (!inherits(object, "GlmBayesMfp")) {
      stop(simpleError("object must be of class GlmBayesMfp"))
    }

    ## other checks
    stopifnot(
      is.list(config),
      is.numeric(zValues),
      is.bool(conditional),
      is.bool(debug),
      is.bool(higherOrderCorrection)
    )

    ## get the old attributes of the object
    attrs <- attributes(object)

    ## check if the model is the null model
    modelSize <- length(unlist(config))
    isNullModel <- identical(modelSize, 0L)
    if (isNullModel) {
      stop(simpleError("the null model has no z which could be sampled..."))
    }

    ## pack the info in a handy list:

    ## pack the options
    options <- list(
      zValues = as.double(zValues),
      conditional = conditional,
      debug = debug,
      higherOrderCorrection = higherOrderCorrection
    )

    ## then call C++ to do the rest:
    results <- cpp_evalZdensity(
      config,
      attrs$data,
      attrs$fpInfos,
      attrs$ucInfos,
      attrs$fixInfos,
      attrs$distribution,
      options
    )

    ## finally return the whole stuff.
    return(results)
  }

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* gmx *.* net]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[McmcOptions-methods.R] by DSB Die 25/05/2010 18:01 (CEST)>
##
## Description:
## Functions/methods for the MCMC formal class.
##
## History:
## 10/12/2009   copy from the master package
#####################################################################################

##' Compute the number of samples for a given MCMC options triple
##'
##' @param mcmcOptions the \code{\linkS4class{McmcOptions}} object
##' @return the resulting sample size
##'
##' @keywords programming
##' @export
sampleSize <-
  function(mcmcOptions) {
    stopifnot(is(mcmcOptions, "McmcOptions"))

    return(as.integer(ceiling((mcmcOptions@iterations - mcmcOptions@burnin) / mcmcOptions@step)))
  }


##' Convert samples to mcmc objects
##'
##' @param samples samples matrix or vector
##' @param mcmcOptions the \code{\linkS4class{McmcOptions}} object which was chosen for the
##' production of \code{samples}
##' @return an S3 class \dQuote{mcmc} object
##'
##' @importFrom coda mcmc
##' @keywords programming
##' @export
convert2Mcmc <- function(samples,
                         mcmcOptions) {
  stopifnot(is(mcmcOptions, "McmcOptions"))

  return(coda::mcmc(
    data = samples,
    start = mcmcOptions@burnin + 1L,
    end = mcmcOptions@iterations,
    thin = mcmcOptions@step
  ))
}

#####################################################################################
## Author: Daniel Sabanes Bove [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[posteriors.R] by DSB Die 25/05/2010 15:11 (CEST)>
##
## Description:
## Extract posterior model probability estimates from a GlmBayesMfp object.
##
## History:
## 01/12/2009   modify from bfp package, and add roxygen tags;
##              add logmarglik and logprior extractor functions
#####################################################################################

##' Extract posterior model probability estimates from a GlmBayesMfp object
##'
##' @param GlmBayesMfpObject the object
##' @param type type of posterior model probability estimates to be extracted from
##' \code{GlmBayesMfpObject}
##' @return the requested probs from all models
##'
##' @export
##' @keywords utilities
posteriors <- function(GlmBayesMfpObject,
                       type = c("normalized", "sampling")) {
  ## match the type argument
  type <- match.arg(type)

  ## index is translated from type
  ind <- switch(type,
    normalized = 1L,
    sampling = 2L
  )

  ## check ...
  ## ... does the first model have the probability estimate?
  stopifnot(!is.na(GlmBayesMfpObject[[1]]$information$posterior[ind]))

  ## now extract the requested probs from all models
  sapply(GlmBayesMfpObject, function(one) one$information$posterior[ind])
}

## ****************************************************************************************************

##' Extract the log marginal likelihood estimates from a GlmBayesMfp object
##'
##' @param GlmBayesMfpObject the object
##' @return the vector of log marginal likelihood estimates
##'
##' @export
##' @keywords utilities
logMargLiks <- function(GlmBayesMfpObject) {
  sapply(
    GlmBayesMfpObject,
    function(one) one$information$logMargLik
  )
}

## ****************************************************************************************************

##' Extract the log prior values from a GlmBayesMfp object
##'
##' @param GlmBayesMfpObject the object
##' @return the vector of log prior values
##'
##' @export
##' @keywords utilities
logPriors <- function(GlmBayesMfpObject) {
  sapply(
    GlmBayesMfpObject,
    function(one) one$information$logPrior
  )
}

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* gmx *.* net]
## Project: Bayesian FPs for GLMs
##
## Time-stamp: <[McmcOptions-class.R] by DSB Mit 15/12/2010 13:57 (CET)>
##
## Description:
## Encapsulate the three canonical MCMC options in a formal class.
##
## History:
## 10/12/2009   copy from the master package
## 25/05/2010   include the optional argument "samples" in the constructor
## 08/07/2010   coerce default iterations to integer in constructor
## 13/12/2010   "samples" must have default value in the ctr
#####################################################################################

##' Class for the three canonical MCMC options
##'
##' The slots are:
##' \describe{
##' \item{iterations}{number of MCMC iterations}
##' \item{burnin}{number of burn-in iterations which are not saved}
##' \item{step}{only every step-th iteration is saved after the burn-in}
##' }
##'
##' @name McmcOptions-class
##' @keywords classes internal
setClass(
  Class = "McmcOptions",
  representation =
    representation(
      iterations = "integer",
      burnin = "integer",
      step = "integer"
    ),
  validity = function(object) {
    if (object@burnin < 0L) {
      return("Burn-in must be non-negative")
    } else if (object@burnin >= object@iterations) {
      return("Burn-in must be smaller than iterations")
    } else if (object@step < 1) {
      return("Step size must be at least 1")
    }
  }
)

##' Constructor for class McmcOptions
##'
##' Note that the argument \code{samples} is included for convenience only -
##' you can specify it instead of \code{iterations}.
##'
##' @param iterations number of MCMC iterations (default: \code{110,000})
##' @param burnin number of burn-in iterations which are not saved (default:
##' \code{10,000})
##' @param step only every step-th iteration is saved after the burn-in
##' (default: \code{10})
##' @param samples number of resulting samples (by default \code{10,000} will result)
##' @return the freshly built object of class \code{\linkS4class{McmcOptions}}
##'
##' @keywords classes
##' @export
McmcOptions <-
  function(iterations = as.integer(burnin + (step * samples)),
           burnin = 1e4L,
           step = 10L,
           samples = 1e4L) {
    return(new(
      Class = "McmcOptions",
      iterations = iterations,
      burnin = burnin,
      step = step
    ))
  }

#####################################################################################
## Author: Daniel Sabanés Bové [daniel *.* sabanesbove *a*t* ifspm *.* uzh *.* ch]
## Project: BFPs for GLMs
##
## Time-stamp: <[helpers.R] by DSB Die 16/02/2010 13:10 (CET)>
##
## Description:
## Helper functions
##
## History:
## 16/02/2010   file creation
#####################################################################################

##' Predicate checking for a boolean option
##'
##' @param x the object being checked
##' @return Returns \code{TRUE} if \code{x} is a length one logical vector (i.e., a
##' scalar)
##'
##' @keywords internal
##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
is.bool <- function(x) {
  return(identical(length(x), 1L) && is.logical(x))
}

/*
 * bfgs.cpp
 *
 *  Created on: 11.11.2009
 *      Author: daniel
 */

#include "bfgs.h"
#include "rcppExport.h"
#include "functionWraps.h"

using namespace Rcpp;

// ***************************************************************************************************//



// just an R interface to bfgs, for regression testing purposes.
// [[Rcpp::export]]
SEXP
cpp_bfgs(SEXP r_startval, SEXP r_function, SEXP r_minx, SEXP r_maxx, SEXP r_precision, SEXP r_verbose  )
{
    // extract function and start value for minimization
    // r_interface = CDR(r_interface);
    // SEXP r_startval = CAR(r_interface);
    // 
    // r_interface = CDR(r_interface);
    // SEXP r_function = CAR(r_interface);
    // 
    // // constraints on the argument
    // r_interface = CDR(r_interface);
    // SEXP r_minx = CAR(r_interface);
    // 
    // r_interface = CDR(r_interface);
    // SEXP r_maxx= CAR(r_interface);
    // 
    // // and the settings
    // r_interface = CDR(r_interface);
    // SEXP r_precision = CAR(r_interface);
    // 
    // r_interface = CDR(r_interface);
    // SEXP r_verbose = CAR(r_interface);

    // wrap the R function to a cached function
    RFunction fun(r_function);
    CachedFunction<RFunction> cachedFun(fun);

    // then minimize (with constraints)
    Bfgs<CachedFunction<RFunction> > bfgs(cachedFun,
                                          Rf_asLogical(r_verbose) == 1,
                                          Rf_asReal(r_minx),
                                          Rf_asReal(r_maxx),
                                          Rf_asReal(r_precision));

    double xMin = 0.0;
    double invHessMin = 0.0;

    int code = bfgs.minimize(Rf_asReal(r_startval),
                             xMin,
                             invHessMin);

    // pack results into R list
    return List::create(_["par"] = xMin,
                        _["inv.hessian"] = invHessMin,
                        _["evaluations"] = cachedFun.getCache().convert2list(),
                        _["code"] = code);
}

// ***************************************************************************************************//

// End of file.


/*
 * bfgs.h
 *
 *  Created on: 13.11.2009
 *      Author: daniel
 */

#ifndef BFGS_H_
#define BFGS_H_

#include "functionWraps.h"

// ***************************************************************************************************//


// the main Bfgs class
template<class Fun>
class Bfgs {
public:
    // setup the object
    // - function is the function to be maximized (possibly constrained)
    // - verbose: print progress on R screen?
    // - lowerBound: lower bound on the function argument (default: -Inf)
    // - upperBound: upper bound on the function argument (default: +Inf)
    // - precision is precision parameter for the flatness at the maximum.
    // - ftol and gtol are convergence parameters
    // - stepsize is a parameter for the first ("crude") step of the algorithm
    Bfgs(Fun& function,
         bool verbose=false,
         double lowerBound=R_NegInf,
         double upperBound=R_PosInf,
         double precision=0.00001,
         double ftol=0.0001,
         double gtol=0.9,
         double stepsize=3.0) :
             function(function),
             functionDeriv(function),
             verbose(verbose),
             lowerBound(lowerBound),
             upperBound(upperBound),
             precision(precision),
             ftol(ftol),
             gtol(gtol),
             stepsize(stepsize)
             {
             }

    // minimize the function and compute the minimum and the inverted hessian at the minimum
    int
    minimize (double x0, double& xMin, double& invHessMin);

private:
    // the function we want to maximize
    Fun& function;

    // and its numerical derivative
    NumericDerivative<Fun> functionDeriv;

    // echo progress?
    const bool verbose;

    // constraints on the function argument
    const double lowerBound;
    const double upperBound;

    // settings
    const double precision;
    const double ftol;
    const double gtol;
    const double stepsize;


    // internal linesearch class:
    // (benefit is encapsulation and access to parent class members,
    // here function, functionDeriv, and settings)
    class Linesearch {
    public:
        Linesearch(const Bfgs& bfgs, // reference to instance of enclosing class must be passed!!
                   // there is no automatic connection of nested class instances to the enclosing class instance.
                   double x,
                   double direction) :
                       bfgs(bfgs),
                       x(x),
                       direction(direction),
                       maxAlpha((direction < 0) ?
                                ((bfgs.lowerBound - x) / direction) :
                                ((bfgs.upperBound - x) / direction))
                       {
                       }

        // do the linesearch for a given start point alpha1
        double
        operator()(double alpha1) const;

    private:

        // reference to the enclosing object
        const Bfgs& bfgs;

        // the point x and the direction of the search
        const double x;
        const double direction;

        // the maximum alpha to be chosen: set by the constructor.
        const double maxAlpha;

         // objective and derivative of objective function are member functions
        double
        phi(double alpha) const
        {
            return bfgs.function(x + alpha * direction);
        }

        double
        phi_(double alpha) const
        {
            return bfgs.functionDeriv(x + alpha * direction) * direction;
        }

        // other helper functions
        bool
        armijo(double alpha) const
        {
            return phi(alpha) <= (phi(0.0) + bfgs.ftol * alpha * phi_(0.0));
        }

        bool
        curvature(double alpha) const
        {
            return fabs(phi_(alpha)) <= - bfgs.gtol * phi_(0.0);
        }

        double
        interpolate(double x0,
                    double x1,
                    double f0,
                    double f1,
                    double g0) const;

        double
        zoom(double alpha_lo,
             double alpha_hi) const;
    };
};


// ***************************************************************************************************//

template <class Fun>
double
Bfgs<Fun>::Linesearch::zoom(double alpha_lo,
                       double alpha_hi) const
{
    for (int i = 0; i < 30; ++i)
    {
        double alpha = interpolate(alpha_lo, alpha_hi, phi(alpha_lo), phi(alpha_hi), phi_(alpha_lo));

        if ((! armijo(alpha)) || (phi(alpha) >= phi(alpha_lo)))
        {
            alpha_hi = alpha;
        }
        else
        {
            if (curvature(alpha))
            {
                return alpha;
            }

            // started going uphill?
            if (phi_(alpha) * (alpha_hi - alpha_lo) >= 0.0)
            {
                alpha_hi = alpha_lo;
            }
            alpha_lo = alpha;
        }
    }
    return 0.0; // not enough progress; give up.
}


// Implements the More-Thuente linesearch algorithm.  The notation is taken from
// Nocedal and Wright (2006).  This function returns an approximate solution to
//
//       argmin_{alpha \in [0, maxAlpha]} phi(alpha).
//
// To avoid getting stuck in local minima, the algorithm attempts to find a
// point that satisfies the Wolfe conditions:
//  - Armijo condition: the function has decreased enough.  This is controlled
// by the "ftol" parameter.
//  - curvature condition: the function has flattened out enough.  This is
// controlled by the "gtol" parameter.
// (It will succeed at this, unless machine precision gets in the way.)
//
// The basic idea of the algorithm is:
//  - do a crude search to find an interval that contains a local minimum
// that satisfies the Wolfe conditions.
//  - do a bisection-like search on that interval, until a point is found
// that satisfies the Wolfe conditions.
//
// In particular, the algorithm doesn't attempt to find a local minimizer.
// It just tries to find a rough guess, which is much faster.  The function
// that calls linesearch will do it many times.  Since the Wolfe conditions
// are relative to the starting point of "linesearch", each subsequent call
// will give tighter approximations.
//
// The algorithm will terminate if the objective eventually starts decreasing,
// or a finite constraint on alpha is specified.
//
// Parameters:
//  - phi : R -> R is the objective function to minimize.
//  - phi_ : R -> R is the derivative of phi.
//  - alpha1 is the starting point.
//  - maxAlpha is an upper-bound constraint on alpha (can be Inf).
template <class Fun>
double
Bfgs<Fun>::Linesearch::operator()(double alpha1) const
{
    // initial check
    if (! (phi_(0) < 0.0))
    {
        Rf_warning("\nBfgs: phi_(0) >= 0.0 in linesearch algorithm");
    }

    // initialize old and new alpha
    double alpha_ = 0.0;
    double alpha = (alpha1 >= maxAlpha) ? maxAlpha / 2.0 : alpha1;

    // iterate at most 100 times
    for (int i = 0; i < 100; ++i)
    {
        if ((i > 0 && (phi(alpha) >= phi(alpha_))) || (! armijo(alpha)))
        {
            return zoom(alpha_, alpha);
        }
        else if (curvature(alpha))
        {
            return alpha;
        }
        else if (phi_(alpha) >= 0.0)
        {
            return zoom(alpha, alpha_);
        }
        else
        {
            alpha_ = alpha;
            alpha = fmin((alpha + maxAlpha) / 2.0,
                         alpha * bfgs.stepsize);
        }
    }

    // return the last alpha if we did not break out of the loop beforehand.
    return alpha;
}

// ***************************************************************************************************//

// the actual minimization function:
// returns
// -1           lost precision
// 0            ok
// 1            change not large enough
template <class Fun>
int
Bfgs<Fun>::minimize(double x0, double& xMin, double& invHessMin)
{
    // first check that start value fulfills constraints.
    const bool insideBounds = (x0 >= lowerBound) && (x0 <= upperBound);
    if(! insideBounds)
    {
        Rf_error("Start value x0=%f for BFGS minimization not in admissible interval [%f, %f]", x0, lowerBound, upperBound);
    }

    // initialization
    xMin = x0;
    invHessMin = 1.0;

    int iter = 0;

    if(verbose)
    {
        Rprintf("\nBfgs: Starting BFGS minimization ...");
    }

    // as long as the gradient is far enough away from zero
    while (fabs(functionDeriv(xMin)) > precision)
    {
        ++iter;

        // possibly echo progress
        if (verbose)
        {
            Rprintf("\nBfgs: now at iteration %d", iter);
        }

        // minimize in the direction of p
        double p = - invHessMin * functionDeriv(xMin);

        // linesearch for factor alpha, starting from alpha = 1,
        // with point x into direction p.

        // first get maximum alpha


        double alpha = Linesearch(*this, xMin, p)(1.0);

        // check result of linesearch:
        // have we lost precision?
        if (alpha == 0.0)
        {
            // then warn
            if(verbose)
            {
                Rprintf("\nBfgs: Lost precision in linesearch of iteration %d", iter);
                Rprintf("\nBfgs: Finished minimization.");
            }

            // and give back the current results and the error code
            return(-1);
        }
        else if ((2.0 * fabs(alpha * p)) < precision)
        {
            // also break if the change is not large enough.
            if (verbose)
            {
                Rprintf("\nBfgs: Change not large enough in iteration %d", iter);
                Rprintf("\nBfgs: Finished minimization.");
            }

            return(1);
        }

        // compute the new x
        double x_ = xMin + alpha * p;

        // inverted Hessian is numeric deriv of g at the new x_:
        invHessMin = (x_ - xMin) / (functionDeriv(x_) - functionDeriv(xMin));

        // so now we are at x_
        xMin = x_;
    }

    if(verbose)
    {
        Rprintf("\nBfgs: Finished minimization.");
    }

    // return the convergence code
    return 0;
}

// ***************************************************************************************************//

// does quadratic interpolation to solve for the minimum on [x0, x1]
//       f(x) = ax^2 + bx + c
//
// (1) f(x0) = f0        => f0 = a x0^2 + b x0 + c
// (2) f(x1) = f1        => f1 = a x1^2 + b x1 + c
// (3) f'(x0) = g0       => g0 = 2a x0 + b
//
// (1)-(2)       f0 - f1 = a (x0^2 - x1^2) + b(x0 - x1)
// from (3):     b = g0 - 2a x0
// from (1)-(2): f0 - f1 = a (x0^2 - x1^2) + (g0 - 2a x0)(x0 - x1)
//               f0 - f1 - g0(x0 - x1) = a (x0^2 - x1^2) - 2a x0(x0 - x1)
//               f0 - f1 - g0(x0 - x1) = a [(x0^2 - x1^2) - 2 x0(x0 - x1)]
//               a = [f0 - f1 - g0(x0 - x1)] / [(x0^2 - x1^2) - 2 x0(x0 - x1)]
//                = - [f0 - f1 - g0(x0 - x1)] / [(x0 - x1)^2]
//
// Then, f'(x) = 2ax + b.  The "minimum" is at x = - b / (2a).
// (corrected here by DSB, it's not at x = -2a / b !!)
// of course, it is only the minimum if f''(x) = 2a > 0,
// which implies that f0 - f1 - g0(x0 - x1) < 0,
// or in other words g0 < (f0 - f1) / (x0 - x1) if x0 < x1.
template <class Fun>
double
Bfgs<Fun>::Linesearch::interpolate(double x0,
                                   double x1,
                                   double f0,
                                   double f1,
                                   double g0) const
{
    double dx = x0 - x1;
    double a = - (f0 - f1 - g0 * dx) / (dx * dx);
    double b = g0 - 2.0 * a * x0;

    double x = - b / (2.0 * a);

    // if it fails: return just the mid-point of [x0, x1]
    if ((R_finite(x) != 1) || (x < fmin(x0, x1)) || (x > fmax(x0, x1)))
    {
        return (x0 + x1) / 2.0;
    }
    else
    {
        return x;
    }
}

// ***************************************************************************************************//


#endif /* BFGS_H_ */

/*
 * functionWraps.h
 *
 *  Created on: 06.11.2009
 *      Author: daniel
 */

#ifndef FUNCTIONWRAPS_H_
#define FUNCTIONWRAPS_H_

#include "rcppExport.h"
#include "types.h"

// ***************************************************************************************************//

// wrap a simple R function,
// taking a double argument and returning a double.
class RFunction
{
public:
    // constructor
    RFunction(SEXP R_fun) :
        fun(R_fun)
        {}

//    // copy constructor
//    RFunction(const RFunction& old);
//
//    // destructor
//    ~RFunction();
//
//    // assignment operator
//    RFunction& operator=(const RFunction& rhs);

    // for use as a function (function object)
    double
    operator()(double x) const;

private:
    Rcpp::Function fun;
};

// ***************************************************************************************************//

// now wrap an R function taking vectors of fixed length
class VectorRFunction
{
public:
    // constructor
    VectorRFunction(SEXP R_function, R_len_t argsize) :
        fun(R_function),
        argsize(argsize)
        {}

    // for use as a function (function object)
    double
    operator()(const double* vector) const;

private:
    Rcpp::Function fun;
    PosInt argsize;
};

// ***************************************************************************************************//

// simple function value cache
class Cache
{
public:
    // save one pair of argument and function value
    void
    save(double arg, double val);

    // extract the arguments
    MyDoubleVector
    getArgs() const
    {
        return args;
    }

    // extract the function values
    MyDoubleVector
    getVals() const
    {
        return vals;
    }

    // clear the cache
    void
    clear();

    // look for an already computed function value
    double
    getValue(double arg) const;

    // initialize from an R list
    Cache(Rcpp::List& rcpp_list);

    // default ctr is allowed as well
    Cache(){};

    // convert to an R list
    Rcpp::List
    convert2list() const;

private:
    MyDoubleVector args;
    MyDoubleVector vals;
};

// ***************************************************************************************************//

// cache all function results
template<class Fun>
    class CachedFunction
    {
    public:
        // constructor takes function object reference and stores it.
        CachedFunction(Fun& function) :
            function(function)
        {
        }

        // return the cached values
        Cache
        getCache() const
        {
            return cache;
        }

        // for use as a function
        double
        operator()(double x);

    private:
        Fun& function;
        Cache cache;
    };

// ***************************************************************************************************//

// get derivative of a function
template<class Fun>
    class NumericDerivative
    {
    public:
        // save the function (object) reference
        NumericDerivative(Fun& function) :
            function(function)
        {
        }

        // for use as a function
        double
        operator()(double x) const;

    private:
        Fun& function;
    };

// ***************************************************************************************************//

// get more accurate derivative of a function
template<class Fun>
    class AccurateNumericDerivative
    {
    public:
        // save the function (object) reference
        AccurateNumericDerivative(Fun& function,
                                  double eps = 0.1) :
            function(function),
            h(eps),
            ntab(10),
            con(1.4),
            con2(con * con),
            big(DBL_MAX),
            safe(2.0)
        {
            if(eps <= 0)
            {
                Rf_error("eps must be positive in AccurateNumericDerivative");
            }
        }

        // for use as a function
        double
        operator()(double x) const;

    private:
        Fun& function;
        const double h;

        // sets maximum size of tableau
        const int ntab;

        // stepsize is decreased by factor con at each iteration
        const double con;
        const double con2;
        const double big;

        // return when error is safe worse than the best so far
        const double safe;
    };


// ***************************************************************************************************//

// get inverse second derivative of a function
template<class Fun>
    class NumericInvHessian
    {
    public:
        // save the function (object) reference and the epsilon parameter
        NumericInvHessian(Fun& function,
                          double eps = EPS) :
            function(function),
            eps(eps)
        {
        }

        // for use as a function
        double
        operator()(double x) const;

    private:
        Fun& function;
        const double eps;
    };

// ***************************************************************************************************//

// get more accurate inverse second derivative of a function
template<class Fun>
    class AccurateNumericInvHessian
    {
    public:
        // save the function (object) reference and the epsilon parameter
        AccurateNumericInvHessian(Fun& function) :
            function(function)
        {
        }

        // for use as a function
        double
        operator()(double x) const;

    private:
        Fun& function;
    };
// ***************************************************************************************************//

// for use as a function
template <class Fun>
double
CachedFunction<Fun>::operator()(double x)
{
    double ret = cache.getValue(x);

    // if not found in the old arguments
    if(R_IsNA(ret))
    {
        // we have to compute and save it.
        ret = function(x);
        cache.save(x, ret);
    }

    // finally return the value (either found or newly computed)
    return ret;
}

// ***************************************************************************************************//

// for use as a function
template <class Fun>
double
NumericDerivative<Fun>::operator()(double x) const
{
    // if abs(x) is (almost) zero, take delta = eps; otherwise delta = x*eps.
    // (important here: use of fabs instead of abs, which is an integer [!] version)
    double delta = (fabs(x) == 0.0) ? EPS : x * EPS;

    // return the estimated derivative at x:
    return (function(x + delta) - function(x)) / delta;
}

// ***************************************************************************************************//

// for use as a function
template <class Fun>
double
AccurateNumericDerivative<Fun>::operator()(double x) const
{
    // modified from
    // http://www.koders.com/cpp/fid192DE24D3250B7B3632C6F54490A67268C992E28.aspx?s=Chebyshev
    // (Numerical Recipes)

    double hh = h;
    double err = big;

    std::vector<MyDoubleVector> a (ntab, MyDoubleVector (ntab, 0));

    a[0][0] = (function(x + hh) - function(x - hh)) / (2.0 * hh);

    double answer = a[0][0];

    for (int i = 1; i < ntab; i++)
    {
        // Successive columns in the Neville tableau will go to smaller
        // stepsizes and higher orders of extrapolation
        hh /= con;

        // Try new smaller stepsize:
        a[0][i] = (function(x + hh) - function(x - hh)) / (2.0 * hh);

        double fac = con2;

        // Compute extrapolation of various orders, requiring no new function evaluations
        for (int j = 1; j <= i; j++)
        {
            a[j][i] = (a[j-1][i] * fac - a[j-1][i-1]) / (fac - 1.0);

            fac = con2 * fac;

            double errt = fmax(fabs(a[j][i] - a[j-1][i]),
                               fabs(a[j][i] - a[j-1][i-1]));

            // The error strategy is to compare each new extrapolation to one order lower,
            // both at the present stepsize and the previous one.

            // If error is decreased, save the improved answer.
            if (errt <= err)
            {
                err = errt;
                answer = a[j][i];
            }
        }

        // If higher order is worse by a significant factor safe, then quit early.
        if (fabs(a[i][i] - a[i-1][i-1]) >= safe * err)
            break;
    }

    return answer;
}

// ***************************************************************************************************//

// for use as a function
template <class Fun>
double
NumericInvHessian<Fun>::operator()(double x) const
{

    // if abs(x) is (almost) zero, take delta = eps; otherwise delta = x * eps.
    // (important here: use of fabs instead of abs, which is an integer [!] version)
    double delta = (fabs(x) == 0.0) ? eps : x * eps;
    delta = fabs(delta);

    // ensure that the difference between x and x + delta is exactly delta:
    double volatile temp = x + delta;
    delta = temp - x;

    // return the estimated inverse hessian at x:
    // (this is the analytical simplification of the centered differences formula, using the same
    // delta for the first and the second numerical derivative)
    // cf. Abramowitz/Stegun p. 884, formula 25.3.24.
    double forward = function(x + delta) - function(x);
    double backward = function(x) - function(x - delta);
    double ret = (delta * delta) / (forward - backward);

    return ret;
}

// ***************************************************************************************************//

// for use as a function
template <class Fun>
double
AccurateNumericInvHessian<Fun>::operator()(double x) const
{
    // get the accurate derivative of the function
    AccurateNumericDerivative<Fun> firstDerivative(function);

    // and the accurate derivative of the first derivative
    AccurateNumericDerivative<AccurateNumericDerivative<Fun> > secondDerivative(firstDerivative);

    // so the result is
    double ret = 1.0 / secondDerivative(x);

    // return that
    return ret;
}

// ***************************************************************************************************//

#endif /* FUNCTIONWRAPS_H_ */

// Modified by Isaac Gravestock (isaac.gravestock@uzh.ch)
// 
// 13/07/2015: Update code to be compatible with CRAN
//             Replace cout and exit
//

#include "combinatorics.h"
#include <iostream>
#include "types.h"
#include <cstdlib>
#include <Rcpp.h>

//using std::cout;
using namespace Rcpp;

void ksub_next ( int n, int k, IntVector& a, bool *more, int &m, int &m2)

//****************************************************************************80
//
//  Purpose:
//
//    KSUB_NEXT generates the subsets of size K from a set of size N.
//
//  Modified:
//
//    29 May 2003
//
//  Reference:
//
//    Albert Nijenhuis, Herbert Wilf,
//    Combinatorial Algorithms,
//    Academic Press, 1978, second edition,
//    ISBN 0-12-519260-6.
//
//  Parameters:
//
//    Input, int N, the size of the set from which subsets are drawn.
//
//    Input, int K, the desired size of the subsets.  K must
//    be between 0 and N.
//
//    Output, int A[K].  A[I] is the I-th element of the
//    subset.  Thus A[I] will be an integer between 1 and N.
//    Note that the routine will return the values in A
//    in sorted order: 1 <= A[0] < A[1] < ... < A[K-1] <= N
//
//    Input/output, bool *MORE.  Set MORE = FALSE before first call
//    for a new sequence of subsets.  It then is set and remains
//    TRUE as long as the subset computed on this call is not the
//    final one.  When the final subset is computed, MORE is set to
//    FALSE as a signal that the computation is done.
//
//    
//   
{
  int j;

  if ( k < 0 || n < k )
  {
    Rcout << "\n";
    Rcout << "KSUB_NEXT - Fatal error!\n";
    Rcout << "N = " << n << "\n";
    Rcout << "K = " << k << "\n";
    Rcout << "but 0 <= K <= N is required!\n";
    //exit ( 1 );
    stop("Invalid parameters");
  }

  if ( !( *more ) )
  {
    m2 = 0;
    m = k;
  }
  else
  {
    if ( m2 < n-m )
    {
      m = 0;
    }
    m = m + 1;
    m2 = a[k-m];
  }

  for ( j = 1; j <= m; j++ )
  {
    a[k+j-m-1] = m2 + j;
  }

  *more = ( a[0] != (n-k+1) );

  return;
}

// ****************************************************************************************//

void comp_next ( int n, int k, IntVector& a, bool *more, int &h, int &t)

//****************************************************************************80
//
//  Purpose:
//
//    COMP_NEXT computes the compositions of the integer N into K parts.
//
//  Discussion:
//
//    The routine computes one composition on each call until there are no more.
//    For instance, one composition of 6 into 3 parts is
//    3+2+1, another would be 6+0+0.
//
//  Example:
//
//    The 28 compositions of 6 into three parts are:
//
//      6 0 0,  5 1 0,  5 0 1,  4 2 0,  4 1 1,  4 0 2,
//      3 3 0,  3 2 1,  3 1 2,  3 0 3,  2 4 0,  2 3 1,
//      2 2 2,  2 1 3,  2 0 4,  1 5 0,  1 4 1,  1 3 2,
//      1 2 3,  1 1 4,  1 0 5,  0 6 0,  0 5 1,  0 4 2,
//      0 3 3,  0 2 4,  0 1 5,  0 0 6.
//
//  Modified:
//
//    28 May 2003
//
//  Author:
//
//    Albert Nijenhuis, Herbert Wilf,
//
//    C++ translation by John Burkardt.
//
//  Reference:
//
//    Albert Nijenhuis, Herbert Wilf,
//    Combinatorial Algorithms,
//    Academic Press, 1978, second edition,
//    ISBN 0-12-519260-6.
//
//  Parameters:
//
//    Input, int N, the integer whose compositions are desired.
//
//    Input, int K, the number of parts in the composition.
//
//    Input/output, int A[K], the parts of the composition.
//
//    Input/output, bool *MORE.
//    Set MORE = FALSE on first call.  It will be reset to TRUE on return
//    with a new composition.  Each new call returns another composition until
//    MORE is set to FALSE when the last composition has been computed
//    and returned.
//
{

  int i;

  if ( ! ( *more ) )
  {
    t = n;
    h = 0;
    a[0] = n;
    for ( i = 1; i < k; i++ )
    {
       a[i] = 0;
    }
  }
  else
  {
    if ( 1 < t )
    {
      h = 0;
    }

    h = h + 1;
    t = a[h-1];
    a[h-1] = 0;
    a[0] = t - 1;
    a[h] = a[h] + 1;

  }

  *more = ( a[k-1] != n );

  return;
}

/*
 * coxfit.cpp
 *
 *  Created on: 30.11.2012
 *      Author: daniel
 *
 *  Modified from R's internal cox fit function for Efron / Breslow ties method,
 *  R-2.15.2/src/library/Recommended/survival/src/coxfit6.c
 *  Three other functions related to Cholesky factorization and solving are
 *  also taken from the R sources.
 *
 */

#include "rcppExport.h"
#include "types.h"
#include "coxfit.h"

using namespace Rcpp;

/*
** A very few pathologic cases can cause the Newton Raphson iteration
**  path in coxph to generate a horrific argument to exp().  Since all these
**  calls to exp result in (essentially) relative risks we choose a
**  fixed value of LARGE on biological grounds: any number less than
**  1/(population of the earth) is essentially a zero, that is, an exponent
**  outside the range of +-23.
** A sensible numeric limit would be log(.Machine$double.xmax) which is
**  about 700, perhaps divided by 2 or log(n) to keep a few more bits.
**  However, passing this down the R calling chain to the c-routine is a lot
**  more hassle than I want to implement for this very rare case.
**
** Actually, the argument does not have to get large enough to have any
**  single exponential overflow.  In (start, stop] data we keep a running
**  sum of scores exp(x[i]*beta), which involves both adding subjects in and
**  subtracting them out.  An outlier x value that enters and then leaves can
**  erase all the digits of accuracy.  Most machines have about 16 digits of
**  accuracy and exp(21) uses up about 9 of them, leaving enough that the
**  routine doesn't fall on it's face.  (A user data set with outlier that
**  got exp(54) and a overlarge first beta on the first iteration led to this
**  paragraph.)  When beta-hat is infinite and x well behaved, the loglik
**  usually converges before xbeta gets to 15, so this protection should not
**  harm the iteration path of even edge cases; only fix those that truely
**  go astray.
**
** The truncation turns out not to be necessary for small values, since a risk
**  score of exp(-50) or exp(-1000) or 0 all give essentially the same effect.
** We only cut these off enough to avoid underflow.
*/

#define LARGE 22
#define SMALL -200

double coxsafe(double x) {
    if (x< SMALL) return(SMALL);
    if (x> LARGE) return(LARGE);
    return (x);
    }




/* $Id: cholesky2.c 11357 2009-09-04 15:22:46Z therneau $
**
** subroutine to do Cholesky decompostion on a matrix: C = FDF'
**   where F is lower triangular with 1's on the diagonal, and D is diagonal
**
** arguments are:
**     n         the size of the matrix to be factored
**     **matrix  a ragged array containing an n by n submatrix to be factored
**     toler     the threshold value for detecting "singularity"
**
**  The factorization is returned in the lower triangle, D occupies the
**    diagonal and the upper triangle is left undisturbed.
**    The lower triangle need not be filled in at the start.
**
**  Return value:  the rank of the matrix (non-negative definite), or -rank
**     it not SPD or NND
**
**  If a column is deemed to be redundant, then that diagonal is set to zero.
**
**   Terry Therneau
*/

int cholesky2(DoubleMatrix& matrix, int n, double toler)
    {
    double temp;
    int  i,j,k;
    double eps, pivot;
    int rank;
    int nonneg;

    nonneg=1;
    eps =0;
    for (i=0; i<n; i++) {
        if (matrix[i][i] > eps)  eps = matrix[i][i];
        for (j=(i+1); j<n; j++)  matrix[j][i] = matrix[i][j];
        }
    eps *= toler;

    rank =0;
    for (i=0; i<n; i++) {
        pivot = matrix[i][i];
        if (pivot < eps) {
            matrix[i][i] =0;
            if (pivot < -8*eps) nonneg= -1;
            }
        else  {
            rank++;
            for (j=(i+1); j<n; j++) {
                temp = matrix[j][i]/pivot;
                matrix[j][i] = temp;
                matrix[j][j] -= temp*temp*pivot;
                for (k=(j+1); k<n; k++) matrix[k][j] -= temp*matrix[k][i];
                }
            }
        }
    return(rank * nonneg);
    }

/* $Id: chinv2.c 11357 2009-09-04 15:22:46Z therneau $
**
** matrix inversion, given the FDF' cholesky decomposition
**
** input  **matrix, which contains the chol decomp of an n by n
**   matrix in its lower triangle.
**
** returned: the upper triangle + diagonal contain (FDF')^{-1}
**            below the diagonal will be F inverse
**
**  Terry Therneau
*/

void chinv2(DoubleMatrix& matrix , int n)
     {
     double temp;
     int i,j,k;

     /*
     ** invert the cholesky in the lower triangle
     **   take full advantage of the cholesky's diagonal of 1's
     */
     for (i=0; i<n; i++){
          if (matrix[i][i] >0) {
              matrix[i][i] = 1/matrix[i][i];   /*this line inverts D */
              for (j= (i+1); j<n; j++) {
                   matrix[j][i] = -matrix[j][i];
                   for (k=0; k<i; k++)     /*sweep operator */
                        matrix[j][k] += matrix[j][i]*matrix[i][k];
                   }
              }
          }

     /*
     ** lower triangle now contains inverse of cholesky
     ** calculate F'DF (inverse of cholesky decomp process) to get inverse
     **   of original matrix
     */
     for (i=0; i<n; i++) {
          if (matrix[i][i]==0) {  /* singular row */
                for (j=0; j<i; j++) matrix[j][i]=0;
                for (j=i; j<n; j++) matrix[i][j]=0;
                }
          else {
              for (j=(i+1); j<n; j++) {
                   temp = matrix[j][i]*matrix[j][j];
                   if (j!=i) matrix[i][j] = temp;
                   for (k=i; k<j; k++)
                        matrix[i][k] += temp*matrix[j][k];
                   }
              }
          }
     }

/*  $Id: chsolve2.c 11376 2009-12-14 22:53:57Z therneau $
**
** Solve the equation Ab = y, where the cholesky decomposition of A and y
**   are the inputs.
**
** Input  **matrix, which contains the chol decomp of an n by n
**   matrix in its lower triangle.
**        y[n] contains the right hand side
**
**  y is overwriten with b
**
**  Terry Therneau
*/

void chsolve2(const DoubleMatrix& matrix, int n, AVector& y)
     {
     int i,j;
     double temp;

     /*
     ** solve Fb =y
     */
     for (i=0; i<n; i++) {
          temp = y[i] ;
          for (j=0; j<i; j++)
               temp -= y[j] * matrix[i][j] ;
          y[i] = temp ;
          }
     /*
     ** solve DF'z =b
     */
     for (i=(n-1); i>=0; i--) {
          if (matrix[i][i]==0)  y[i] =0;
          else {
              temp = y[i]/matrix[i][i];
              for (j= i+1; j<n; j++)
                   temp -= y[j]*matrix[j][i];
              y[i] = temp;
              }
          }
     }




// getter for results
CoxfitResults
Coxfit::finalizeAndGetResults()
{
    // copy the contents of the DoubleMatrix imat into
    // the Armadillo matrix results.imat
    for(int i = 0; i < nCovs; ++i)
    {
        for(int j = 0; j < nCovs; ++j)
        {
            results.imat.at(i, j) = imat[i][j];
        }
    }
    // the other results are already up to date, because
    // their storage is directly used in the fit function.

    // then return the results
    return results;
}


// check results
void
Coxfit::checkResults() const
{
    // todo: replace errors by exceptions later on

    if(results.flag < nCovs)
    {
        Rf_error("Singular model!");
    }

    AVector infs = results.imat * results.u;

    if(iterMax > 1)
    {
        if (results.flag == 1000)
        {
            Rf_error("Ran out of iterations and did not converge");
        }
        else
        {
            IntVector notConverged;

            for(int i=0; i < nCovs; ++i)
            {
                if((infs[i] > eps) && (infs[i] > tolerInf * fabs(results.coefs[i])))
                {
                    notConverged.push_back(i + 1);
                }
            }

            if(notConverged.size() > 0)
            {
                Rf_warning("Loglik converged before some variables; beta may be infinite. ");
            }
        }
    }
}


// the fit function, returns the number of
// required iterations
int
Coxfit::fit()
{
    int i,j,k, person;

    double  wtave;
    double  denom=0, zbeta, risk;
    double  temp, temp2;
    int     ndead;  /* actually, the sum of their weights */
    double  newlk = 0.0;
    double  dtime, d2;
    double  deadwt;  /*sum of case weights for the deaths*/
    double  efronwt; /* sum of weighted risk scores for the deaths*/
    int     halving;    /*are we doing step halving at the moment? */
    int     nrisk;   /* number of subjects in the current risk set */

    /* copies of scalar input arguments */
    int     nused, nvar, maxiter;
    double  toler;
    int doscale;

    /* returned objects */
    int iter;

    /* get local copies of some input args */
    nused = nObs;
    nvar  = nCovs;
    maxiter = iterMax;
    toler = tolerChol;  /* tolerance for cholesky */
    doscale = 1;

    /*
     **  Set up the ragged arrays and scratch space
     */

    AVector a(nvar);
    AVector newbeta(nvar);
    AVector a2(nvar);
    AVector scale(nvar);

    DoubleMatrix cmat(nvar, nvar);
    DoubleMatrix cmat2(nvar, nvar);

    /*
     ** Subtract the mean from each covar, as this makes the regression
     **  much more stable.
     */
    for (i=0; i<nvar; i++) {
        temp=0;
        for (person=0; person<nused; person++) temp += X(person, i);
        temp /= nused;
        for (person=0; person<nused; person++)
        {
            X(person, i) -=temp;
        }
        if (doscale==1) {  /* and also scale it */
            temp =0;
            for (person=0; person<nused; person++) {
                temp += fabs(X(person, i));
            }
            if (temp > 0) temp = nused/temp;   /* scaling */
            else temp=1.0; /* rare case of a constant covariate */
            scale[i] = temp;
            for (person=0; person<nused; person++)
            {
                X(person, i) *= temp;
            }
        }
    }
    if (doscale==1) {
        for (i=0; i<nvar; i++) results.coefs[i] /= scale[i]; /*rescale initial betas */
    }
    else {
        for (i=0; i<nvar; i++) scale[i] = 1.0;
    }

    /*
     ** do the initial iteration step
     */
    strata[nused-1] =1;
    results.loglik[1] =0;
    for (i=0; i<nvar; i++) {
        results.u[i] =0;
        a2[i] =0;
        for (j=0; j<nvar; j++) {
            imat[i][j] =0 ;
            cmat2[i][j] =0;
        }
    }

    for (person=nused-1; person>=0; ) {
        if (strata[person] == 1) {
            nrisk =0 ;
            denom = 0;
            for (i=0; i<nvar; i++) {
                a[i] = 0;
                for (j=0; j<nvar; j++) cmat[i][j] = 0;
            }
        }

        dtime = survTimes[person];
        ndead =0; /*number of deaths at this time point */
        deadwt =0;  /* sum of weights for the deaths */
        efronwt=0;  /* sum of weighted risks for the deaths */
        while(person >=0 &&survTimes[person]==dtime) {
            /* walk through the this set of tied times */
            nrisk++;
            zbeta = offsets[person];    /* form the term beta*z (vector mult) */
            for (i=0; i<nvar; i++)
                zbeta += results.coefs[i]*X(person, i);
            zbeta = coxsafe(zbeta);
            risk = exp(zbeta) * weights[person];
            denom += risk;

            /* a is the vector of weighted sums of x, cmat sums of squares */
            for (i=0; i<nvar; i++) {
                a[i] += risk*X(person, i);
                for (j=0; j<=i; j++)
                    cmat[i][j] += risk * X(person, i) * X(person, j);
            }

            if (censInd[person]==1) {
                ndead++;
                deadwt += weights[person];
                efronwt += risk;
                results.loglik[1] += weights[person]*zbeta;

                for (i=0; i<nvar; i++)
                    results.u[i] += weights[person]*X(person, i);
                if (method==1) { /* Efron */
                    for (i=0; i<nvar; i++) {
                        a2[i] +=  risk*X(person, i);
                        for (j=0; j<=i; j++)
                            cmat2[i][j] += risk* X(person, i) * X(person, j);
                    }
                }
            }

            person--;
            if (strata[person]==1) break;  /*ties don't cross strata */
        }


        if (ndead >0) {  /* we need to add to the main terms */
            if (method==0) { /* Breslow */
                results.loglik[1] -= deadwt* log(denom);

                for (i=0; i<nvar; i++) {
                    temp2= a[i]/ denom;  /* mean */
                    results.u[i] -=  deadwt* temp2;
                    for (j=0; j<=i; j++)
                        imat[j][i] += deadwt*(cmat[i][j] - temp2*a[j])/denom;
                }
            }
            else { /* Efron */
                /*
                 ** If there are 3 deaths we have 3 terms: in the first the
                 **  three deaths are all in, in the second they are 2/3
                 **  in the sums, and in the last 1/3 in the sum.  Let k go
                 **  from 0 to (ndead -1), then we will sequentially use
                 **     denom - (k/ndead)*efronwt as the denominator
                 **     a - (k/ndead)*a2 as the "a" term
                 **     cmat - (k/ndead)*cmat2 as the "cmat" term
                 **  and reprise the equations just above.
                 */
                for (k=0; k<ndead; k++) {
                    temp = (double)k/ ndead;
                    wtave = deadwt/ndead;
                    d2 = denom - temp*efronwt;
                    results.loglik[1] -= wtave* log(d2);
                    for (i=0; i<nvar; i++) {
                        temp2 = (a[i] - temp*a2[i])/ d2;
                        results.u[i] -= wtave *temp2;
                        for (j=0; j<=i; j++)
                            imat[j][i] +=  (wtave/d2) *
                            ((cmat[i][j] - temp*cmat2[i][j]) -
                                    temp2*(a[j]-temp*a2[j]));
                    }
                }

                for (i=0; i<nvar; i++) {
                    a2[i]=0;
                    for (j=0; j<nvar; j++) cmat2[i][j]=0;
                }
            }
        }
    }   /* end  of accumulation loop */
    results.loglik[0] = results.loglik[1]; /* save the loglik for iter 0 */

    /* am I done?
     **   update the betas and test for convergence
     */
    for (i=0; i<nvar; i++) /*use 'a' as a temp to save u0, for the score test*/
        a[i] = results.u[i];

    results.flag= cholesky2(imat, nvar, toler);
    chsolve2(imat,nvar,a);        /* a replaced by  a *inverse(i) */


    /*
     **  Never, never complain about convergence on the first step.  That way,
     **  if someone HAS to they can force one iter at a time.
     */
    for (i=0; i<nvar; i++) {
        newbeta[i] = results.coefs[i] + a[i];
    }
    if (maxiter==0) {
        chinv2(imat,nvar);
        for (i=0; i<nvar; i++) {
            results.coefs[i] *= scale[i];  /*return to original scale */
            results.u[i] /= scale[i];
            imat[i][i] *= scale[i]*scale[i];
            for (j=0; j<i; j++) {
                imat[j][i] *= scale[i]*scale[j];
                imat[i][j] = imat[j][i];
            }
        }
        return 0;
    }

    /*
     ** here is the main loop
     */
    halving =0 ;             /* =1 when in the midst of "step halving" */
    for (iter=1; iter<= maxiter; iter++) {
        newlk =0;
        for (i=0; i<nvar; i++) {
            results.u[i] =0;
            for (j=0; j<nvar; j++)
                imat[i][j] =0;
        }

        /*
         ** The data is sorted from smallest time to largest
         ** Start at the largest time, accumulating the risk set 1 by 1
         */
        for (person=nused-1; person>=0; ) {
            if (strata[person] == 1) { /* rezero temps for each strata */
                denom = 0;
                nrisk =0;
                for (i=0; i<nvar; i++) {
                    a[i] = 0;
                    for (j=0; j<nvar; j++) cmat[i][j] = 0;
                }
            }

            dtime = survTimes[person];
            deadwt =0;
            ndead =0;
            efronwt =0;
            while(person>=0 && survTimes[person]==dtime) {
                nrisk++;
                zbeta = offsets[person];
                for (i=0; i<nvar; i++)
                    zbeta += newbeta[i]*X(person, i);
                zbeta = coxsafe(zbeta);
                risk = exp(zbeta) * weights[person];
                denom += risk;

                for (i=0; i<nvar; i++) {
                    a[i] += risk*X(person, i);
                    for (j=0; j<=i; j++)
                        cmat[i][j] += risk*X(person, i)*X(person, j);
                }

                if (censInd[person]==1) {
                    ndead++;
                    deadwt += weights[person];
                    newlk += weights[person] *zbeta;
                    for (i=0; i<nvar; i++)
                        results.u[i] += weights[person] *X(person, i);
                    if (method==1) { /* Efron */
                        efronwt += risk;
                    for (i=0; i<nvar; i++) {
                        a2[i] +=  risk*X(person, i);
                        for (j=0; j<=i; j++)
                            cmat2[i][j] += risk*X(person, i)*X(person, j);
                    }
                    }
                }

                person--;
                if (strata[person]==1) break; /*tied times don't cross strata*/
            }

            if (ndead >0) {  /* add up terms*/
                if (method==0) { /* Breslow */
                    newlk -= deadwt* log(denom);
                    for (i=0; i<nvar; i++) {
                        temp2= a[i]/ denom;  /* mean */
                        results.u[i] -= deadwt* temp2;
                        for (j=0; j<=i; j++)
                            imat[j][i] +=  (deadwt/denom)*
                            (cmat[i][j] - temp2*a[j]);
                    }
                }
                else  { /* Efron */
                    for (k=0; k<ndead; k++) {
                        temp = (double)k / ndead;
                        wtave= deadwt/ ndead;
                        d2= denom - temp* efronwt;
                        newlk -= wtave* log(d2);
                        for (i=0; i<nvar; i++) {
                            temp2 = (a[i] - temp*a2[i])/ d2;
                            results.u[i] -= wtave*temp2;
                            for (j=0; j<=i; j++)
                                imat[j][i] +=  (wtave/d2)*
                                ((cmat[i][j] - temp*cmat2[i][j]) -
                                        temp2*(a[j]-temp*a2[j]));
                        }
                    }

                    for (i=0; i<nvar; i++) { /*in anticipation */
                        a2[i] =0;
                        for (j=0; j<nvar; j++) cmat2[i][j] =0;
                    }
                }
            }
        }   /* end  of accumulation loop  */

        /* am I done?
         **   update the betas and test for convergence
         */
        results.flag = cholesky2(imat, nvar, toler);

        if (fabs(1-(results.loglik[1]/newlk))<= eps && halving==0) { /* all done */
            results.loglik[1] = newlk;
            chinv2(imat, nvar);     /* invert the information matrix */
            for (i=0; i<nvar; i++) {
                results.coefs[i] = newbeta[i]*scale[i];
                results.u[i] /= scale[i];
                imat[i][i] *= scale[i]*scale[i];
                for (j=0; j<i; j++) {
                    imat[j][i] *= scale[i]*scale[j];
                    imat[i][j] = imat[j][i];
                }
            }
            return iter;
        }

        if (iter== maxiter) break;  /*skip the step halving calc*/

        if (newlk < results.loglik[1])   {    /*it is not converging ! */
            halving =1;
            for (i=0; i<nvar; i++)
                newbeta[i] = (newbeta[i] + results.coefs[i]) /2; /*half of old increment */
        }
        else {
            halving=0;
            results.loglik[1] = newlk;
            chsolve2(imat,nvar,results.u);
            j=0;
            for (i=0; i<nvar; i++) {
                results.coefs[i] = newbeta[i];
                newbeta[i] = newbeta[i] + results.u[i];
            }
        }
    }   /* return for another iteration */

    /*
     ** We end up here only if we ran out of iterations
     */
    results.loglik[1] = newlk;
    chinv2(imat, nvar);
    for (i=0; i<nvar; i++) {
        results.coefs[i] = newbeta[i]*scale[i];
        results.u[i] /= scale[i];
        imat[i][i] *= scale[i]*scale[i];
        for (j=0; j<i; j++) {
            imat[j][i] *= scale[i]*scale[j];
            imat[i][j] = imat[j][i];
        }
    }
    results.flag = 1000;

    return iter;
}


// ***************************************************************************************************//

// compute the residual deviance of this model
double
Coxfit::computeResidualDeviance()
{
    // do the fitting
    fit();

    // get results: need to do that first!
    CoxfitResults fit = finalizeAndGetResults();

    // check results
    checkResults();

    // return residual deviance
    double ret = - 2.0 * (fit.loglik[0] - fit.loglik[1]);
    return ret;
}

// ***************************************************************************************************//

// 03/07/2013: add offsets

// just an R interface to the coxfit routine, for regression testing purposes.
// [[Rcpp::export]]
SEXP
cpp_coxfit(SEXP R_survTimes, SEXP R_censInd, SEXP R_offsets, SEXP R_X, SEXP R_method)
{
    // ---------------
    // get R objects:

    // // extract survival times
    // R_interface = CDR(R_interface);
    // SEXP R_survTimes = CAR(R_interface);
    // 
    // // censoring status
    // R_interface = CDR(R_interface);
    // SEXP R_censInd = CAR(R_interface);
    // 
    // // offsets
    // R_interface = CDR(R_interface);
    // SEXP R_offsets = CAR(R_interface);
    // 
    // // design matrix
    // R_interface = CDR(R_interface);
    // SEXP R_X= CAR(R_interface);
    // 
    // // and the tie method
    // R_interface = CDR(R_interface);
    // SEXP R_method = CAR(R_interface);

    // ---------------
    // unpack R objects:

    // survival times
    const NumericVector n_survTimes = R_survTimes;
    //const AVector survTimes(n_survTimes.begin(), n_survTimes.size(),
    //                      false);
    
    // errors with const and stuff... what if we copy into new memory?
    const AVector survTimes(n_survTimes.begin(), n_survTimes.size());

    // censoring status
    const IntVector censInd = as<IntVector>(R_censInd);

    // offsets
    const AVector offsets = as<NumericVector>(R_offsets);

    // design matrix
    const NumericMatrix n_X = R_X;
    //const AMatrix X(n_X.begin(), n_X.nrow(),
    //                n_X.ncol(), false);
    
    //Same issue as above L717:721
    const AMatrix X(n_X.begin(), n_X.nrow(),
                    n_X.ncol());
    

    // tie method
    const int method = as<int>(R_method);

    // ---------------
    // assign remaining arguments for Coxfit

    const int nObs = survTimes.size();

    const AVector weights = arma::ones<AVector>(nObs);

    // ---------------

    // get new Coxfit object
    Coxfit cox(survTimes,
               censInd,
               X,
               weights,
               offsets,
               method);

    // do the fitting
    const int nIter = cox.fit();

    // get results: need to do that first!
    CoxfitResults fit = cox.finalizeAndGetResults();

    // check results
    cox.checkResults();

    // pack results into R list and return that
    return List::create(_["coef"] = fit.coefs,
                        _["imat"] = fit.imat,
                        _["loglik"] = fit.loglik,
                        _["nIter"] = nIter);

}


/*
 * coxfit.h
 *
 *  Created on: 03.12.2012
 *      Author: daniel
 */

#ifndef COXFIT_H_
#define COXFIT_H_

#include "types.h"

//  Dynamic_2d_array class by David Maisonave (609-345-1007) (www.axter.com)
//  Description:
//      The dynamic array class listed below is more efficient then other
//      similar classes that use temporary objects as return types, or use
//      an std::vector as a return type.
//
//      It's also more compatible with a C style 2D array, in that the
//      array is in one continuous memory block. This makes it possible
//      to pass this array object to a C Function that has a C-Style
//      2D array for a parameter.
//  Example usage:
/*

Dynamic_2d_array<int> MyIntArray(12, 34);
MyIntArray[0][1] = 123;
cout << MyIntArray[0][1] << endl;

*/

template < class T >
class Dynamic_2d_array
{
public:
  // constructor
  Dynamic_2d_array(int row, int col) :
    m_row(row),
    m_col(col),
    m_data((row!=0 && col!=0) ? new T[row*col] : NULL)
  {}

  // copy ctr
  Dynamic_2d_array(const Dynamic_2d_array& src) :
    m_row(src.m_row),
    m_col(src.m_col),
    m_data((src.m_row!=0 && src.m_col!=0) ? new T[src.m_row*src.m_col] : NULL)
  {
    for(int r=0; r<m_row; ++r)
      for(int c=0; c<m_col; ++c)
        (*this)[r][c] = src[r][c];
  }

  // destructor
  ~Dynamic_2d_array()
  {
    delete[] m_data;
  }

  // non-const access
  inline T* operator[](int i)
  {
    return (m_data + (m_col*i));
  }

  // const access
  inline T const*const operator[](int i) const
  {
    return (m_data + (m_col*i));
  }

private:
  const int m_row;
  const int m_col;
  T* m_data;
};

// Note that the class Dynamic_2d_array automatically allocates and
// deallocates the memory.
typedef Dynamic_2d_array<long> LongMatrix;
typedef Dynamic_2d_array<double> DoubleMatrix;
typedef Dynamic_2d_array<int> IntMatrix;

// **************************************************************************************


struct CoxfitResults
{
    // constructor:
    CoxfitResults(const int nCovs) :
        coefs(nCovs),
        imat(nCovs, nCovs),
        u(nCovs),
        loglik(2),
        flag(0)
    {
        // fill with initial values for the null model:
        coefs.fill(0.0);
    }


    // the coefficient vector
    AVector coefs;

    // the covariance matrix estimate
    AMatrix imat;

    // the score vector
    AVector u;

    // the log likelihoods of the initial coef vector and
    // the final one
    MyDoubleVector loglik;

    // convergence flag
    int flag;
};


// **************************************************************************************


// The class which does the Cox model fitting
class Coxfit {

public:

    // ctr
    Coxfit(const AVector& survTimes,
           const IntVector& censInd,
           const AMatrix& X,
           const AVector& weights,
           const AVector& offsets,
           const int method,
           double eps = 1e-09,
           double tolerChol = pow(DBL_EPSILON, 0.75),
           int iterMax = 40,
           double tolerInf = 1e-05) :
               survTimes(survTimes),
               censInd(censInd),
               X(X),
               weights(weights),
               offsets(offsets),
               method(method),
               nObs(survTimes.size()),
               nCovs(X.n_cols),
               strata(nObs, 0),
               imat(nCovs, nCovs),
               results(nCovs),
               eps(eps),
               tolerChol(tolerChol),
               iterMax(iterMax),
               tolerInf(tolerInf)
               {}

    // getter for results
    CoxfitResults
    finalizeAndGetResults();

    // check results
    void
    checkResults() const;

    // the fit function, returns the number of
    // required iterations
    int
    fit();

    // compute the residual deviance of this model
    double
    computeResidualDeviance();

private:

    // inputs
    AVector survTimes;
    IntVector censInd;
    AMatrix X;
    AVector weights;
    AVector offsets;
    const int method;

    const int nObs;
    const int nCovs;

    IntVector strata;

    // temporary storage
    DoubleMatrix imat;

    // outputs
    CoxfitResults results;

    // numerical options
    const double eps;
    const double tolerChol;
    const int iterMax;
    const double tolerInf;
};

#endif /* COXFIT_H_ */

#include <set>
#include <algorithm>
#include <cmath>
#include <string>
#include <sstream>

#include "dataStructure.h"
#include "sum.h"
#include "functionWraps.h"
#include "fpUcHandling.h"

#include "rcppExport.h"

using std::lexicographical_compare;
using std::accumulate;
using std::exp;
using std::log;

using namespace Rcpp;

// ***************************************************************************************************//

// safeSum //

void SafeSum::add(const long double &val)
{
        vals.push_back(val);
}

long double SafeSum::sum()
{
        long double ret = modified_deflation(vals);
        return ret;
}

// compute the log of the sum of the exp of the elements using accurate algorithm,
// and avoiding infinite contributions.
long double SafeSum::logSumExp()
{
    // be sure that there is at least 1 value in "vals"
    if(vals.empty())
    {
        return R_NaN;
    }

    // the maximum of the log contributions is:
    long double maxLogContrib = *std::max_element(vals.begin(), vals.end());

    // now compute the constant which is added to all log contributions,
    // in order to avoid infinite contributions and at the same time use
    // the whole number space (i.e. possibly avoid zero contributions)
    long double constant = log(LDBL_MAX) - 100.0L - maxLogContrib;
    // 100 is for safety.

    // so now the contributions, offset by the constant
    LongDoubleVector expVals;
    for(LongDoubleVector::const_iterator
            l = vals.begin();
            l != vals.end();
            ++l)
    {
        expVals.push_back(exp(*l + constant));
    }

    // the result is the log of the sum, corrected with the constant:
    long double ret = log(modified_deflation(expVals)) - constant;
    return ret;
}

long double SafeSum::simpleSum()
{
        long double ret = 0.0;
        for(LongDoubleVector::const_iterator
                v = vals.begin();
                v != vals.end();
                ++v)
        {
            ret += *v;
        }
        return ret;
}

// ***************************************************************************************************//

// indexSafeSum //

void IndexSafeSum::add(const Ind& ind)
{
        indices.insert(ind);
}

long double
IndexSafeSum::sumNormalizedExp(const SafeSum& s, long double logNormConst) const
{
    LongDoubleVector tempVec;
    for (IndSet::const_iterator i = indices.begin(); i != indices.end(); i++)
    {
        tempVec.push_back(exp(s.vals.at(* i) - logNormConst));
    }
    return modified_deflation(tempVec);
}

// ***************************************************************************************************//


// Book //

// 21/11/2012: add tbf option

// constructor which checks the chainlength
Book::Book(bool tbf,
           bool doGlm,
           bool empiricalBayes,
           bool useFixedg,
           bool useFixedc,
           double cl,
           bool doSampling,
           bool verbose,
           std::string modelPrior,
           PosInt nModels,
           PosInt nCache,
           double largeVariance,
           bool useBfgs,
           bool debug,
           bool higherOrderCorrection) :
           modelCounter(0),
                nanCounter(0),
                tbf(tbf),
                doGlm(doGlm),
                empiricalBayes(empiricalBayes),
                useFixedg(useFixedg),
                useFixedc(useFixedc),
                doSampling(doSampling),
                verbose(verbose),
                modelPrior(modelPrior),
                nModels(nModels),
                nCache(nCache),
                largeVariance(largeVariance),
                useBfgs(useBfgs),
                debug(debug),
                higherOrderCorrection(higherOrderCorrection)
{
    if (doSampling)
    {
        // check if chainlength is too large
        if (ULLONG_MAX < cl)
        {
            Rf_warning("\nchainlength too high - reducing to %llu\n", ULLONG_MAX);
            chainlength = ULONG_MAX;
        }
        else
        {
            chainlength = static_cast<PosLargeInt> (cl);
        }
    }
    else
    {
        // we will do an exhaustive model search, so initialize chainlength
        // with a non-usable number:
        chainlength = 0;
    }
}


// ***************************************************************************************************//

// GlmModelInfo //

// convert to Rcpp list
List
GlmModelInfo::convert2list(long double logNormConst,
                           const Book& bookkeep) const
{
    return List::create(_["logMargLik"] = logMargLik,
                        _["logPrior"] = logPrior,
                        _["posterior"] = NumericVector::create(exp(logPost - logNormConst),
                                                               bookkeep.doSampling ? (hits * 1.0 / bookkeep.chainlength) : NA_REAL),
                        _["negLogUnnormZDensities"] = negLogUnnormZDensities.convert2list(),
                        _["zMode"] = zMode,
                        _["zVar"] = zVar,
                        _["laplaceApprox"] = laplaceApprox,
                        _["residualDeviance"] = residualDeviance);
}


// ***************************************************************************************************//

bool ModelPar::operator<(const ModelPar& m) const
{ 
	// return size() < m.size(); way too easy... lexicographical comparison, starting with uc indices:
	if (ucPars < m.ucPars)
		return true;
	else if (ucPars > m.ucPars)
		return false;
	else // uc indices are equal
		return lexicographical_compare(fpPars.begin(), fpPars.end(), m.fpPars.begin(), m.fpPars.end());	
}

// ***************************************************************************************************//

// return a textual description of this model configuration
std::string
ModelPar::print(const FpInfo& fpInfo) const
{
    // put everything into a stringstream, and return the string conversion at the end.
    std::ostringstream stream;

    // ask for two significant digits
    stream.precision(2);

    // Start
    stream << "\nmodel with " << fpSize << " FP powers and " << ucPars.size() << " UC groups.\n\nIncluded FP powers:";

    if(fpSize > 0)
    {
        // in parallel to the power index vector, go along the names vector
        StrVector::const_iterator n = fpInfo.fpnames.begin();
        for(PowersVector::const_iterator
                i = fpPars.begin();
                i != fpPars.end();
                ++i, ++n)
        {
            // if there is at least one power
            if(i->size() > 0)
            {
                // print the name
                stream << "\nFor " << *n << ": ";

                // and all powers
                MyDoubleVector thesePowers = fpInfo.inds2powers(*i);
                for(MyDoubleVector::const_iterator
                        p = thesePowers.begin();
                        p != thesePowers.end();
                        ++p)
                {
                    stream << *p << " ";
                }
            }
        }
    }
    else
    {
        stream << "\nnone";
    }


    stream << "\n\nIndexes of included UC groups:";

    if(ucPars.size() > 0)
    {
        for(IntSet::const_iterator
                i = ucPars.begin();
                i != ucPars.end();
                ++i)
        {
            stream << " " << *i;
        }
    }
    else
    {
        stream << " none";
    }
    
    stream << "\n\nIndexes of included fixed groups:";
    
    if(fixPars.size() > 0)
    {
      for(IntSet::const_iterator
            i = fixPars.begin();
          i != fixPars.end();
          ++i)
      {
        stream << " " << *i;
      }
    }
    else
    {
      stream << " none";
    }

    // return the resulting string
    return stream.str();
}

// ***************************************************************************************************//

// convert R list to ModelPar
ModelPar::ModelPar(List rcpp_configuration,
                   const FpInfo& fpInfo) :
                   fpSize(0),
                   ucPars(as<IntSet>(rcpp_configuration["ucTerms"])),
                   fixPars(as<IntSet>(rcpp_configuration["fixTerms"]))
{
    // get the list with the FP power vectors:
    List rcpp_powers = rcpp_configuration["powers"];

    // now process all fp names saved in the fpInfo, to construct the correct PowersVector
    for(StrVector::const_iterator s = fpInfo.fpnames.begin();
            s != fpInfo.fpnames.end();
            ++s)
    {
        // get the list element with this name,
        // a double vector,
        // and get the Powers object from that (that is, convert double vector to indexes)
        Powers powers(fpInfo.vec2inds(as<MyDoubleVector>(rcpp_powers[*s])));

        // we have started with fpSize = 0, so we can just add the number of powers now
        fpSize += powers.size();

        // save the powers at the right place
        fpPars.push_back(powers);
    }

    // now we are sure that the PowersVector fpPars is parallel to the fpInfo stuff.
}


// ***************************************************************************************************//

List
ModelPar::convert2list(const FpInfo& currFp) const
{
    // powers
    List powers(fpPars.size());
    powers.names() = currFp.fpnames;

    for (PosInt i = 0; i != fpPars.size(); ++i)
    {
        powers[i] = currFp.inds2powers(fpPars[i]);
    }

    // return with uc settings
    return List::create(_["ucTerms"] = ucPars,
                        _["powers"] = powers,
                        _["fixTerms"] = fixPars);
}


// ***************************************************************************************************//

// compute set of free uc group indices in a model configuration
IntSet
ModelPar::getFreeUcs(const PosIntVector& ucSizes,
                     const PosInt& currDim,
                     const PosInt& maxDim) const
{
    IntSet ret;

    for (PosIntVector::size_type i = 1; i <= ucSizes.size(); i++)
    { // for every uc index
        if ((find(ucPars.begin(), ucPars.end(), i) == ucPars.end())
                && (ucSizes.at(i - 1) <= maxDim - currDim))
        {
            ret.insert(i); // insert if not already in model and enough space in design matrix
        }
    }

    return ret;
}

// ***************************************************************************************************//

// compute set of free cov indices in a model configuration
PosIntSet
ModelPar::getFreeCovs(const FpInfo& currFp,
                      const IntSet& freeUcs,
                      const PosInt& currDim,
                      const PosInt& maxDim) const
{
    PosIntSet ret;

    if (currDim == maxDim)
    {
        return ret;
    }

    for (PosInt i = 0; i != fpPars.size(); i++)
    {
        if (fpPars.at(i).size() < currFp.fpmaxs.at(i))
        {
            ret.insert(i + 1);
        }
    }

    if (! freeUcs.empty())
    {
        ret.insert(fpPars.size() + 1);
    }

    return ret;
}

// ***************************************************************************************************//

// determine set of present cov indices
PosIntSet
ModelPar::getPresentCovs() const
{
    PosIntSet ret;

    for (PosInt i = 0; i != fpPars.size(); i++)
    {
        if (! fpPars.at(i).empty())
        {
            ret.insert(i + 1);
        }
    }

    if (! ucPars.empty())
    {
        ret.insert(fpPars.size() + 1);
    }

    return ret;
}


// ***************************************************************************************************//

// push back index into covGroupWisePosteriors-Array
void
ModelPar::pushInclusionProbs(const FpInfo& fpInfo,
                             const UcInfo& ucInfo,
                             Book& bookkeep) const
{
    for (PosInt i = 0; i != fpInfo.nFps; i++)
    {
        if (! fpPars.at(i).empty())
            bookkeep.covGroupWisePosteriors[i].add(bookkeep.modelCounter);
    }

    for (PosInt i = 1; i <= ucInfo.nUcGroups; i++)
    {
        // search for uc group i
        IntSet::const_iterator ipos = find(ucPars.begin(),
                                           ucPars.end(), i);
        if (ipos != ucPars.end())
        { // if mod.ucPars contains i
            bookkeep.covGroupWisePosteriors[i - 1 + fpInfo.nFps].add(
                                                                     bookkeep.modelCounter);
        }
    }
}



// ***************************************************************************************************//

// we do not need this function because two posteriors will never be exactly equal.
// And if they happen to be equal, we do not care about the number of parameters.

//bool Model::operator<(const Model& m) const  // less
//{
//	double thisLogPost = info.logMargLik + info.logPrior;
//	double mLogPost = m.info.logMargLik + m.info.logPrior;
//	if (thisLogPost < mLogPost)
//		return true;
//	else if (thisLogPost > mLogPost)
//		return false;
//	else  // posteriors are equal, then the parameter makes the decision
//		return m.par < par;
//}

// ***************************************************************************************************//

// return the size of the model (excluding the intercept),
// i.e. the number of coefficients
PosInt 
ModelPar::size(const UcInfo& ucInfo, const FixInfo& fixInfo) const 
{
    // number of FP coefficients is easy
    PosInt ret = fpSize;

    // but be careful for the UC coefficients!
    for(IntSet::const_iterator
            g = ucPars.begin();
            g != ucPars.end();
            ++g)
    {
        ret += ucInfo.ucSizes.at(*g - 1);
    }

    // and for fixed coefficients!
    for(IntSet::const_iterator
          g = fixPars.begin();
        g != fixPars.end();
        ++g)
    {
      ret += fixInfo.fixSizes.at(*g - 1);
    }
    
    // return the total
    return ret;
}

// ***************************************************************************************************//

// convert glm model into list for export to R
List
Model::convert2list(const FpInfo& currFp,
                    long double logNormConst,
                    const Book& bookkeep) const
{
    return List::create(_["configuration"] = par.convert2list(currFp),
                        _["information"] = info.convert2list(logNormConst, bookkeep));
}

// ***************************************************************************************************//

// compute nodes and log weights for given mode and var of target unnormalized density
void
GaussHermite::getNodesAndLogWeights(double mode, double var,
                                    MyDoubleVector& nodes, MyDoubleVector& logWeights) const // output
{
    // logarithm of square root of (2 * var).
    double logSqrt2Var = 0.5 * (M_LN2 + log(var));

    MyDoubleVector::const_iterator t = tVec.begin();
    for(MyDoubleVector::const_iterator
            w = wVec.begin();
            w != wVec.end();
            ++w, ++t)
    {
        nodes.push_back(mode + exp(logSqrt2Var) * (*t));
        logWeights.push_back(log(*w) + (*t) * (*t) + logSqrt2Var);
    }
}

// ***************************************************************************************************//

// GlmModelConfig //

// constructor
GlmModelConfig::GlmModelConfig(List& rcpp_family,
                               double nullModelLogMargLik,
                               double nullModelDeviance,
                               double fixedg,
                               S4& rcpp_gPrior,
                               const AVector& responses,
                               bool debug,
                               bool useFixedc,
                               double empiricalMean,
                               bool empiricalgPrior) :
    dispersions(as<NumericVector>(rcpp_family["dispersions"])),
    weights(as<NumericVector>(rcpp_family["weights"])),
    linPredStart(as<NumericVector>(rcpp_family["linPredStart"])),
    offsets(as<NumericVector>(rcpp_family["offsets"])),
    nullModelLogMargLik(nullModelLogMargLik),
    nullModelDeviance(nullModelDeviance),
    fixedg(fixedg),
    familyString(as<std::string>(rcpp_family["family"])),
    linkString(as<std::string>(rcpp_family["link"])),
    canonicalLink((familyString == "binomial" && linkString == "logit") ||
                      (familyString == "poisson" && linkString == "log")),
    empiricalgPrior(empiricalgPrior)
{
    // and the phi from the R family object
    const double phi = rcpp_family["phi"];

    if (familyString == "binomial")
    {
        distribution = new Binomial(responses,
                                    weights);
    }
    else if (familyString == "gaussian")
    {
        distribution = new Gaussian(responses,
                                    weights,
                                    phi);
    }
    else if (familyString == "poisson")
    {
        distribution = new Poisson(responses,
                                   weights);
    }
    else
    {
        Rf_error("Distribution not implemented");
    }

    if (linkString == "logit")
    {
        link = new LogitLink();
    }
    else if (linkString == "probit")
    {
        link = new ProbitLink();
    }
    else if (linkString == "cloglog")
    {
        link = new CloglogLink();
    }
    else if (linkString == "inverse")
    {
        link = new InverseLink();
    }
    else if (linkString == "log")
    {
        link = new LogLink();
    }
    else if (linkString == "identity")
    {
        link = new IdentityLink();
    }
    else
    {
        Rf_error("Link not implemented!");
    }


    if (useFixedc) {
        
         // from the link and the distribution we can derive the constant factor
         // c = v(h(0)) / h'(0)^2
        double deriv = link->mu_eta(0);
        cfactor = distribution->variance(link->linkinv(0)) / (deriv * deriv);
    }
    else if (!useFixedc) {
      	//Rprintf("used y mean of %f\n", empiricalMean);
        double deriv = link->mu_eta(link->linkfun(empiricalMean));
        cfactor = distribution->variance(link->linkinv(link->linkfun(empiricalMean))) / (deriv * deriv);
        
    }

    if(debug)
    {
       Rprintf("Factor c is %f\n", cfactor);
    }

    // ensure that this is positive
    if(! (cfactor > 0.0))
    {
        Rf_error("cfactor equal to %f, so not positive", cfactor);
    }
    
    //we don't need c if we use the empirical prior
    if(empiricalgPrior) cfactor = 1;

    // finally the g-prior stuff:

    // first get the class name of the S4 g-prior object
    std::string gPriorString = rcpp_gPrior.attr("class");

    // and then depending on the name, initialize our gPrior in C++.
    if (gPriorString == "HypergPrior")
    {
        gPrior = new HypergPrior(as<double>(rcpp_gPrior.slot("a")));
    }
    else if (gPriorString == "InvGammaGPrior")
    {
        gPrior = new InvGammaGPrior(as<double>(rcpp_gPrior.slot("a")),
                                    as<double>(rcpp_gPrior.slot("b")));
    }
    else if (gPriorString == "IncInvGammaGPrior")
    {
        gPrior = new IncInvGammaGPrior(as<double>(rcpp_gPrior.slot("a")),
                                       as<double>(rcpp_gPrior.slot("b")));
    }
    else if (gPriorString == "CustomGPrior")
    {
        gPrior = new CustomGPrior(as<SEXP>(rcpp_gPrior.slot("logDens")));
    }
    else
    {
        Rf_error("g-prior not implemented!");
    }
}


// ***************************************************************************************************//



// dataValues //

// 03/12/2012: add censoring indicator vector

DataValues::DataValues(const AMatrix &x,
                       const AMatrix &xcentered,
                       const AVector &y,
                       const IntVector &censInd,
                       const double &totalNum,
                       const IntSet& fixedCols) :
            design(x),
            centeredDesign(xcentered),
            response(y),
            censInd(censInd),
            nObs(design.n_rows),
            onesVector(arma::ones<AVector>(nObs)),
            totalNumber(static_cast<PosLargeInt> (totalNum)),
            fixedCols(fixedCols)
{
    // and the SST
    AVector centeredResponse = response - arma::mean(response);
    sumOfSquaresTotal = arma::dot(centeredResponse, centeredResponse);
}	



// ***************************************************************************************************//


// ModelCache //

// insert model parameter and corresponding info into cache,
// with caring about the maximum number of elements in the map.
bool
ModelCache::insert(const ModelPar& par, const GlmModelInfo& info)
{
    // first check size of cache
    if(isFull())
    {
        // if we are full, then check if this log posterior is better than
        // the worst cached model, which is pointed to by
        MapType::iterator worstModelIter = *(modelIterSet.begin());

        // the comparison
        if((worstModelIter->second) < info)
        {
            // new model is better than worst model cached.
            // so we delete the worst model from the cache.

            // first from the map
            modelMap.erase(worstModelIter);
            // and then from the set
            modelIterSet.erase(modelIterSet.begin());
        }
        else
        {
            // the new model is not better than the worst model cached,
            // so we do not cache it.
            return false;
        }
    }

    // so now we know that we want to insert the model into the cache,
    // either because the cache was not full or because the new model was better
    // than the worst model cached.

    // -> try inserting into the map:
    std::pair<MapType::iterator, bool> ret = modelMap.insert(MapType::value_type(par, info));

    // if we were successful:
    if(ret.second)
    {
        // then also insert the iterator pointing to the map element into the set.
        modelIterSet.insert(ret.first);

        // return success
        return true;
    }
    else
    {
        return false;
        Rf_error("Should not happen: model already contained in model cache!");
    }
}

// search for the log marginal likelihood of a model config in the map,
// and return NA if not found
GlmModelInfo
ModelCache::getModelInfo(const ModelPar& par) const
{
    // search for the config in the map
    MapType::const_iterator ret = modelMap.find(par);

    // if found, return the log marg lik
    if(ret != modelMap.end())
        return ret->second;
    else
        return GlmModelInfo(R_NaReal, R_NaReal, Cache(), 0.0, 0.0, 0.0, R_NaReal);
}

// increment the sampling frequency for a model configuration
// (of course, if this config is not cached nothing is done)
void
ModelCache::incrementFrequency(const ModelPar& par)
{
    // search for the config in the map
    MapType::iterator ret = modelMap.find(par);

    // if found, increment the hits
    if(ret != modelMap.end())
        ret->second.hits++;
}

// compute the log normalising constant from all cached models
long double
ModelCache::getLogNormConstant() const
{
    // use safe summation
    SafeSum vec;

    // traverse the cache
    for(MapType::const_iterator
            m = modelMap.begin();
            m != modelMap.end();
            ++m)
    {
        // and add all unnormalized log posteriors
        vec.add(m->second.logPost);
    }

    // return the log of the sum of the exp'ed saved elements
    return vec.logSumExp();
}

// compute the inclusion probabilities from all cached models,
// taking the log normalising constant, the number of FPs and the number of UC groups
MyDoubleVector
ModelCache::getInclusionProbs(long double logNormConstant, PosInt nFps, PosInt nUcs) const
{
    // abbreviation
    typedef std::vector<SafeSum> SafeSumVector;
    // allocate vector of safeSum objects for all FPs
    SafeSumVector fps(nFps);

    // and all UC groups
    SafeSumVector ucs(nUcs);

    // now process each model in the cache
    for(MapType::const_iterator
            m = modelMap.begin();
            m != modelMap.end();
            ++m)
    {
        // abbrevs
        const ModelPar& thisPar = m->first;
        const GlmModelInfo& thisInfo = m->second;

        // first process the FPs
        {
        SafeSumVector::iterator s = fps.begin();
        for (PowersVector::const_iterator
                p = thisPar.fpPars.begin();
                p != thisPar.fpPars.end();
                ++p, ++s)
        {
            // is this FP in the model m?
            if (! p->empty())
            {
                // then add the normalized model probability onto his FP stack
                s->add(exp(thisInfo.logPost - logNormConstant));
            }
        }
        }

        // then process the UC groups
        {
        SafeSumVector::iterator s = ucs.begin();
        for (PosInt i = 1; i <= nUcs; ++i, ++s)
        {
            // is this UC group in the model m?
            if (thisPar.ucPars.find(i) != thisPar.ucPars.end())
            {
                // then add the normalized model probability onto his UC stack
                s->add(exp(thisInfo.logPost - logNormConstant));
            }
        }
        }
    } // end processing all models in the cache

    // so now we can sum up safesum-wise to the return double vector
    MyDoubleVector ret;

    for(SafeSumVector::iterator
            s = fps.begin();
            s != fps.end();
            ++s)
    {
        ret.push_back(s->sum());
    }

    for(SafeSumVector::iterator
            s = ucs.begin();
            s != ucs.end();
            ++s)
    {
        ret.push_back(s->sum());
    }

    return ret;
}

// convert the best nModels from the cache into an R list
List
ModelCache::getListOfBestModels(const FpInfo& fpInfo,
                                long double logNormConst,
                                const Book& bookkeep) const
{
    // allocate the return list
    List ret(std::min(bookkeep.nModels,
                      static_cast<PosInt>(modelIterSet.size())));
    // cast is necessary for gcc-4.2 on Mac on R-forge.

    // process the ordered list of best models from the end (because the set is ordered increasingly)
    PosInt i = 0;
    for(SetType::const_reverse_iterator
            s = modelIterSet.rbegin();
            (i < bookkeep.nModels) && (s != modelIterSet.rend());  // so the return list has min(nModels, modelIterSet.size()) elements.
            ++s, ++i)
    {
        // allocate two-element list in the i-th slot of the return list
        ret[i] = List::create(_["configuration"] = (**s).first.convert2list(fpInfo),
                              _["information"] = (**s).second.convert2list(logNormConst,
                                                                           bookkeep));
    }

    return ret;
}


// End of file.


#ifndef DATASTRUCTURE_H_
#define DATASTRUCTURE_H_

#include <set>
#include <map>
#include <vector>
#include <iterator>
#include <numeric>
#include <string>

#include "rcppExport.h"
#include "types.h"
#include "functionWraps.h"
#include "fpUcHandling.h"
#include "links.h"
#include "distributions.h"
#include "gpriors.h"


// ***************************************************************************************************//

struct SafeSum
{
    LongDoubleVector vals;

    void
    add(const long double &val);

    // compute the sum of the elements using accurate algorithm
    long double
    sum();

    // compute the log of the sum of the exp of the elements using accurate algorithm,
    // and avoiding infinite contributions.
    long double
    logSumExp();

    // compute the sum of the elements using very simple algorithm
    long double
    simpleSum();
};

// ***************************************************************************************************//

struct IndexSafeSum
{
    // the model index collection
    IndSet indices;

    // add a model index i to the collection indices
    void
    add(const Ind& i);

    // taking the safe sum object s of log posteriors, and the associated log normalizing
    // constant logNormConst,
    // compute the sum \sum_i in indices exp{s_i - logNormConst}.
    long double
    sumNormalizedExp(const SafeSum& s, long double logNormConst) const;
};

// ***************************************************************************************************//

// 21/11/2012: add tbf option

// bookkeeping, shall later be used by glm and hyper-g!
struct Book
{
    PosLargeInt modelCounter;
    PosLargeInt chainlength;
    PosLargeInt nanCounter;

    SafeSum modelLogPosteriors;
    //IndexSafeSum *covGroupWisePosteriors; // for computation of covariate inclusion probs: array (bfp, uc)
    std::vector<IndexSafeSum> covGroupWisePosteriors; // for computation of covariate inclusion probs: array (bfp, uc)

    const bool tbf;
    const bool doGlm;
    const bool empiricalBayes;
    const bool useFixedg;
    const bool useFixedc;
    const bool doSampling;
    const bool verbose;
    const std::string modelPrior;

    const PosInt nModels;
    const PosInt nCache;

    const double largeVariance;
    const bool useBfgs;
    const bool debug;

    const bool higherOrderCorrection;

    // constructor which checks the chainlength
    Book(bool tbf,
         bool doGlm,
         bool empiricalBayes,
         bool useFixedg,
         bool useFixedc,
         double cl,
         bool doSampling,
         bool verbose,
         std::string modelPrior,
         PosInt nModels,
         PosInt nCache,
         double largeVariance,
         bool useBfgs,
         bool debug,
         bool higherOrderCorrection);

};

// ***************************************************************************************************//

// data structure: model information for general models.
// keep in mind that contents must be assignable.
struct ModelInfo
{
    // most important:
    double logMargLik;
    double logPrior;

    // just the sum of logMargLik and logPrior.
    // But we need it often, so save it here (the ctr computes it).
    double logPost;

    // only needed for MCMC:
    PosLargeInt hits;

    // simple constructor
    ModelInfo(double logMargLik, double logPrior, PosLargeInt hits = 0) :
        logMargLik(logMargLik), logPrior(logPrior), logPost(logMargLik + logPrior), hits(hits)
    {
    }

    // compare two model infos bei their posterior probability:
    // the model info with the lower one is lower.
    bool
    operator<(const ModelInfo& m) const
    {
        return logPost < m.logPost;
    }
};

// ***************************************************************************************************//

//// specialization for normal model with hyper-g prior
//struct NormalModelInfo : public ModelInfo
//{
//    // additional to ModelInfo:
//
//    // posterior expected factor g given this model
//    double postExpectedg;
//
//    // posterior expected shrinkage factor g/(1+g) given this model
//    double postExpectedShrinkage;
//
//    // coefficient of determination for this model
//    double R2;
//
//    // constructor
//    NormalModelInfo(double logMargLik,
//                    double logPrior,
//                    double postExpectedg,
//                    double postExpectedShrinkage,
//                    double R2,
//                    PosLargeInt hits) :
//        ModelInfo(logMargLik, logPrior, hits),
//        postExpectedg(postExpectedg),
//        postExpectedShrinkage(postExpectedShrinkage),
//        R2(R2)
//        {
//        }
//};

// ***************************************************************************************************//

// specialization for GLM model
struct GlmModelInfo : public ModelInfo
{
    GlmModelInfo(double logMargLik,
                 double logPrior,
                 const Cache& cache,
                 double zMode,
                 double zVar,
                 double laplaceApprox,
                 double residualDeviance) :
                     ModelInfo(logMargLik,
                               logPrior),
                     negLogUnnormZDensities(cache),
                     zMode(zMode),
                     zVar(zVar),
                     laplaceApprox(laplaceApprox),
                     residualDeviance(residualDeviance)
                     {
                     }

    // cache of negative log unnormalized posterior density of z evaluations:

    // the z values
    Cache negLogUnnormZDensities;

    // moment estimates:

    // mode of the z posterior (z*)
    double zMode;

    // and associated estimated variance (sigma*^2)
    double zVar;

    // here is the resulting Laplace approximation of the log marginal likelihood
    double laplaceApprox;

    // this is only filled in the TBF case
    double residualDeviance;

    // convert to R list
    Rcpp::List
    convert2list(long double logNormConst,
                 const Book& bookkeep) const;

    // conversion of R list to modelInfo:
    // Cache and hits are not filled!
    explicit
    GlmModelInfo(Rcpp::List rcpp_information) :
        ModelInfo(rcpp_information["logMargLik"],
                  rcpp_information["logPrior"],
                  NA_INTEGER),
                  zMode(rcpp_information["zMode"]),
                  zVar(rcpp_information["zVar"]),
                  laplaceApprox(rcpp_information["laplaceApprox"]),
                  residualDeviance(rcpp_information["residualDeviance"])
    {
    }
};

// ***************************************************************************************************//

// model parameter object: must have a strict weak ordering
struct ModelPar
{
    PowersVector fpPars; // vector of multisets

    // not needed: just use fpPars.size()
    // PosInt nFps; // length of vector

    PosInt fpSize; // number of fp powers
    IntSet ucPars; // set of group indices, starting from 1 (!)
    IntSet fixPars; // set of group indices, starting from 1 (!)

    // not needed: just use ucPars.size()
    // PosInt ucSize; // number of uc Groups included

    // start with an empty (null) model:
    ModelPar(PosInt nFps) :
        fpPars(nFps), fpSize(0), ucPars(), fixPars()
    {
    }

    // comparison of configurations
    bool
    operator<(const ModelPar& m) const;

    // return a textual description of this model configuration
    std::string
    print(const FpInfo& fpInfo) const;

    // return the size of the model (excluding the intercept)
    PosInt
    size(const UcInfo& ucInfo, const FixInfo& fixInfo) const;

    // convert to R list
    Rcpp::List
    convert2list(const FpInfo& currFp) const;

    // convert R list to ModelPar
    ModelPar(Rcpp::List rcpp_configuration,
             const FpInfo& fpInfo);

    // compute set of free uc group indices in a model configuration
    IntSet
    getFreeUcs(const PosIntVector& ucSizes,
               const PosInt& currDim,
               const PosInt& maxDim) const;

    // compute set of free cov indices in a model configuration
    PosIntSet
    getFreeCovs(const FpInfo& currFp,
                const IntSet& freeUcs,
                const PosInt& currDim,
                const PosInt& maxDim) const;

    // determine set of present cov indices
    PosIntSet
    getPresentCovs() const;

    // push back index into covGroupWisePosteriors-Array
    void
    pushInclusionProbs(const FpInfo& fpInfo,
                       const UcInfo& ucInfo,
                       Book& bookkeep) const;
};

// ***************************************************************************************************//


// first only for Glms. Possibly extended with template class for ModelInfo to NormalModelInfo.
struct Model
{
    ModelPar par;
    GlmModelInfo info;

    // initialize
    Model(const ModelPar& p, const GlmModelInfo& i) :
        par(p), info(i)
    {
    }

    // fully forward the comparison to the model parameter and info class.
    // we need to include the par comparison because sometimes
    // really the info is identical...
    bool
    operator<(const Model& m) const // less
    {
        if(info < m.info)
            return true;
        else if(m.info < info)
            return false;
        else
            return par < m.par;
    }

    // model to list
    Rcpp::List
    convert2list(const FpInfo& currFp,
                 long double logNormConst,
                 const Book& bookkeep) const;
};


// ***************************************************************************************************//


class GaussHermite {
public:
    // compute nodes and log weights for given mode and sd of target unnormalized density
    void
    getNodesAndLogWeights(double mode, double var,
                       MyDoubleVector& nodes, MyDoubleVector& logWeights) const; // output

    // constructor
    GaussHermite(Rcpp::List rcpp_gaussHermite) :
        tVec(Rcpp::as<MyDoubleVector>(rcpp_gaussHermite["nodes"])),
        wVec(Rcpp::as<MyDoubleVector>(rcpp_gaussHermite["weights"]))
        {
        }

private:
    const MyDoubleVector tVec; // nodes
    const MyDoubleVector wVec; // weights (not log!)
};


// ***************************************************************************************************//



struct GlmModelConfig
{
    // vector of dispersions (phi / weights)
    const AVector dispersions;

    // vector of weights
    const AVector weights;

    // vector of starting values for the linear predictor
    // constant, because for each model we will initially start from that.
    const AVector linPredStart;

    // the vector of offsets
    const AVector offsets;

    // log marg lik of the the null model
    const double nullModelLogMargLik;

    // deviance of the the null model
    const double nullModelDeviance;

    // fixed value of g
    const double fixedg;

    // the g-prior information
    const GPrior* gPrior;

    // the link information
    const Link* link;

    // the distribution information
    const Distribution* distribution;

    // the constant factor deriving from the link and the distribution,
    // which we need for the generalized g-prior
    double cfactor;

    // save also the names of link and distribution
    const std::string familyString;
    const std::string linkString;

    // does this model use the canonical link?
    const bool canonicalLink;

    // should we use the empirical g prior which uses 
    // the information matrix ( J(B)^-1 ) for the covariance instead of (X'X)^-1
    const bool empiricalgPrior;
    
    // constructor
    GlmModelConfig(Rcpp::List& rcpp_family,
                   double nullModelLogMargLik,
                   double nullModelDeviance,
                   double fixedg,
                   Rcpp::S4& rcpp_gPrior,
                   const AVector& responses,
                   bool debug,
                   bool useFixedc,
                   double empiricalMean,
                   bool empiricalgPrior);

    // destructor
    ~GlmModelConfig()
    {
        delete gPrior;
        delete link;
        delete distribution;
    }
};

// ***************************************************************************************************//


struct DataValues
{
    AMatrix design;
    AMatrix centeredDesign;

    AVector response;
    double sumOfSquaresTotal;

    IntVector censInd;

    int nObs;

    AVector onesVector;

    PosLargeInt totalNumber; // cardinality of model space

    const IntSet fixedCols;

    DataValues(const AMatrix &x,
               const AMatrix &xcentered,
               const AVector &y,
               const IntVector &censInd,
               const double &totalNum,
               const IntSet& fixedCols);
};


// ***************************************************************************************************//

// first only for GLM models:
// the model cache class.

// Caches the best models in a map of a given maximum size, and also stores the
// (unnormalized) log posterior probabilities in an ordered set, pointing to the models in the map.
class ModelCache {
public:


    // create a new ModelCache with given maximum size.
    ModelCache(int maxSize) :
        maxSize(maxSize),
        modelMap(),
        modelIterSet()
        {
        }

    // check if max size was reached
    bool
    isFull() const
    {
        return modelMap.size() == maxSize;
    }

    // return size of cache
    int
    size() const
    {
        return modelMap.size();
    }

    // insert model parameter and belonging model info into the cache.
    // returns false if not inserted (e.g. because the par was
    // already inside, or the model was not good enough)
    bool
    insert(const ModelPar& par, const GlmModelInfo& info);

    // search for the model info of a model config in the map,
    // and return an information with NA for log marg lik if not found
    GlmModelInfo
    getModelInfo(const ModelPar& par) const;

    // increment the sampling frequency for a model configuration
    // (of course, if this config is not cached nothing is done!)
    void
    incrementFrequency(const ModelPar& par);

    // compute the log normalising constant from all cached models
    long double
    getLogNormConstant() const;

    // compute the inclusion probabilities from all cached models,
    // taking the log normalising constant and the total number of FPs / UC groups
    MyDoubleVector
    getInclusionProbs(long double logNormConstant, PosInt nFps, PosInt nUcs) const;

    // convert the best nModels from the cache into an R list
    Rcpp::List
    getListOfBestModels(const FpInfo& fpInfo,
                        long double logNormConst,
                        const Book& bookkeep) const;


private:
    // the map type
    typedef std::map<ModelPar, GlmModelInfo> MapType;

    // define comparison function for iterators
    struct Compare_map_iterators
    {
        bool
        operator()(const MapType::iterator& first, const MapType::iterator& second) const
        {
            return (first->second.logPost) < (second->second.logPost);
        }
    };

    // the set type of ordered map iterators
    typedef std::set<MapType::iterator, Compare_map_iterators> SetType;

    // and finally the data members
    const MapType::size_type maxSize;
    MapType modelMap;
    SetType modelIterSet;
};

// ***************************************************************************************************//

// all information needed in mcmc function
struct ModelMcmc
{
    // initialize with the null model only.
    ModelMcmc(const FpInfo& fpInfo,
              const UcInfo& ucInfo,
              PosInt maxDim,
              double logMargLikNullModel) :
                  modPar(fpInfo.nFps),
                  dim(1),
                  freeUcs(modPar.getFreeUcs(ucInfo.ucSizes, dim, maxDim)),
                  freeCovs(modPar.getFreeCovs(fpInfo, freeUcs, dim, maxDim)),
                  presentCovs(modPar.getPresentCovs()),
                  birthprob(1.0),
                  deathprob(0.0),
                  moveprob(0.0),
                  logMargLik(logMargLikNullModel),
                  logPrior(R_NaN)
    {
    }

    ModelPar modPar;
    PosInt dim; // number of columns in this model's design matrix

    IntSet freeUcs; // indices within uc groups, denoting the birthable ones
    PosIntSet freeCovs; // indices of free covs (starting from first fp with index 1 up to uc index = nFps + 1)
    PosIntSet presentCovs; // analogue

    double birthprob, deathprob, moveprob; // move type probabilities, switchprob is 1-bprob-dprob-mprob.
    double logMargLik;
    double logPrior;
};

// ***************************************************************************************************//

#endif /*DATASTRUCTURE_H_*/

/*
 * distributions.h
 *
 *  Created on: 15.03.2010
 *      Author: daniel
 *
 * Classes for exponential family distributions.
 *
 */

#ifndef DISTRIBUTIONS_H_
#define DISTRIBUTIONS_H_

#include "types.h"
#include "rcppExport.h"


// ***************************************************************************************************//

// General virtual class for an exponential family distribution, including
// the variance function of the modelled mean mu
// and the loglikelihood of a whole vector of modelled means.
// We also always save the vector of scalar responses and weights, because naturally
// the loglikelihood of "means" depends on this!
class Distribution
{
public:
    // ctr:
    Distribution(const AVector& responses,
                 const AVector& weights) :
        responses(responses),
        weights(weights)
        {
        }

    // variance function
    virtual double
    variance(double mu) const = 0;

    // loglikelihood
    virtual double
    loglik(const double *means) const = 0;

    // we need a virtual destructor here,
    // cf. Accelerated C++ pp. 242 ff.
    virtual ~Distribution(){}

protected:
    // the vector of responses
    const AVector responses;

    // the vector of weights
    const AVector weights;
};

// ***************************************************************************************************//

// The binomial distribution
class Binomial : public Distribution
{
public:
    // ctr
    Binomial(const AVector& responses,
             const AVector& weights) :
        Distribution(responses,
                     weights)
        {
        }

    // variance function
    double
    variance(double mu) const
    {
        return mu * (1.0 - mu);
    }

    // loglikelihood
    double
    loglik(const double *means) const;
};

// ***************************************************************************************************//

// The Gaussian distribution
class Gaussian : public Distribution
{
public:
    // ctr
    Gaussian(const AVector& responses,
             const AVector& weights,
             double phi) :
        Distribution(responses, weights),
        phi(phi)
    {
    }

    // variance function
    double
    variance(double mu) const
    {
        return 1.0;
    }

    // loglikelihood
    double
    loglik(const double *means) const;

private:

    // the dispersion factor (variance sigma^2)
    const double phi;
};

// ***************************************************************************************************//

// The Poisson distribution
class Poisson : public Distribution
{
public:
    // ctr
    Poisson(const AVector& responses,
            const AVector& weights) :
        Distribution(responses,
                     weights)
    {
    }

    // variance function
    double
    variance(double mu) const
    {
        return mu;
    }

    // loglikelihood
    double
    loglik(const double *means) const;
};


#endif /* DISTRIBUTIONS_H_ */

/*
 * gpriors.h
 *
 *  Created on: 15.03.2010
 *      Author: daniel
 *
 * Classes for priors on the shrinkage paramater g.
 *
 */

#ifndef GPRIORS_H_
#define GPRIORS_H_

#include "rcppExport.h"
#include "functionWraps.h"


// ***************************************************************************************************//

// Virtual base class for all g priors.
struct GPrior
{
    // Log prior density
    virtual double
    logDens(double g) const = 0;

    // we need a virtual destructor here,
    // cf. Accelerated C++ pp. 242 ff.
    virtual ~GPrior(){}

    // add method which is only overwritten by the incomplete inverse gamma class
    virtual double
    getTBFLogMargLik(double residualDeviance, int df) const
    {
        return R_NaReal;
    }
};

// ***************************************************************************************************//

// Inverse gamma g prior
class InvGammaGPrior : public GPrior
{
public:
    // ctr
    InvGammaGPrior(double a, double b) :
        a(a),
        b(b)
        {
        }

    // Log prior density
    double
    logDens(double g) const
    {
        return - (a + 1.0) * log(g) - b / g + a * log(b) - Rf_lgammafn(a);
    }

private:
    // the parameters for the inverse gamma density
    const double a;
    const double b;
};

// ***************************************************************************************************//

// Incomplete Inverse gamma g prior

class IncInvGammaGPrior : public GPrior
{
public:
    // ctr
    IncInvGammaGPrior(double a, double b) :
        a(a),
        b(b)
        {
        }

    // Log prior density
    double
    logDens(double g) const;

    // for this class we have a closed form for the log marginal likelihood
    // resulting from the TBF approach
    double
    getTBFLogMargLik(double residualDeviance, int df) const;

private:
    // the parameters for the inverse gamma density
    const double a;
    const double b;
};

// ***************************************************************************************************//

// Hyper-g prior
class HypergPrior : public GPrior
{
public:
    // ctr
    HypergPrior(double a) :
        a(a)
        {
        }

    // Log prior density
    double
    logDens(double g) const
    {
        return log(a - 2.0) - M_LN2 - (a / 2.0) * log1p(g);
    }

private:
    // the hyperparameter
    const double a;
};

// ***************************************************************************************************//

// Custom g-prior
class CustomGPrior : public GPrior
{
public:
    // ctr
    CustomGPrior(SEXP R_function) :
        wrappedRfunction(R_function)
        {
        }

    // Log prior density
    double
    logDens(double g) const
    {
        return wrappedRfunction(g);
    }

private:
    // the wrapped R function
    const RFunction wrappedRfunction;
};

// ***************************************************************************************************//


#endif /* GPRIORS_H_ */

/*
 * links.h
 *
 *  Created on: 15.03.2010
 *      Author: daniel
 *
 * Classes for GLM link functions.
 *
 */

#ifndef LINKS_H_
#define LINKS_H_

#include "rcppExport.h"

static const double THRESH = 30.;
static const double MTHRESH = -30.;
static const double INVEPS = 1 / DBL_EPSILON;


// ***************************************************************************************************//

// The general virtual Link class, which includes
// the link function itself,
// the inverse link function (or response function)
// and the derivative of the response function.
class Link
{
public:
    // the link function itself
    virtual double
    linkfun(double mu) const = 0;

    // the inverse link function (or response function)
    virtual double
    linkinv(double eta) const = 0;

    // and the derivative of the response function
    virtual double
    mu_eta(double eta) const = 0;

    // we need a virtual destructor here,
    // cf. Accelerated C++ pp. 242 ff.
    virtual ~Link(){}
};

// ***************************************************************************************************//

// the Logit link class
// inspiration taken from R/src/library/stats/src/family.c,
// because for numerical stability of the IWLS we REALLY NEED the thresholds...
class LogitLink : public Link
{
private:

    /**
     * Evaluate x/(1 - x). An inline function is used so that x is
     * evaluated once only.
     */
    static double x_d_omx(double x)
    {
        if (x < 0 || x > 1)
            Rf_error("Value %f out of range (0, 1)", x);
        return x / (1 - x);
    }

    /**
     * Evaluate x/(1 + x). An inline function is used so that x is
     * evaluated once only.
     */
    static double x_d_opx(double x)
    {
        return x / (1 + x);
    }

public:
    // logit
    double
    linkfun(double mu) const
    {
        return log(x_d_omx(mu));
    }

    // inverse logit
    double
    linkinv(double eta) const
    {
        double tmp = (eta < MTHRESH) ? DBL_EPSILON :
                     ((eta > THRESH) ? INVEPS : exp(eta));
        return x_d_opx(tmp);
    }

    // function(eta) h'(eta) where h is the inverse logit
    double
    mu_eta(double eta) const
    {
        double opexp = 1 + exp(eta);
        double ret = (eta > THRESH || eta < MTHRESH) ? DBL_EPSILON :
                      exp(eta) / (opexp * opexp);
        return ret;
    }
};


// ***************************************************************************************************//

// the Cauchit link class
class CauchitLink : public Link
{
public:
    // ctr
    CauchitLink() :
        thresh(- Rf_qcauchy(DBL_EPSILON, 0.0, 1.0, 1, 0))
        {
        }

    // cauchit == cauchy quantile
    double
    linkfun(double mu) const
    {
        return Rf_qcauchy(mu, 0.0, 1.0, 1, 0);
    }

    // inverse cauchit == cauchy cdf
    // compare in R: binomial("cauchit")$linkinv
    double
    linkinv(double eta) const
    {
        eta = fmin(fmax(eta, - thresh), thresh);
        return Rf_pcauchy(eta, 0.0, 1.0, 1, 0);
    }

    // cauchy density
    double
    mu_eta(double eta) const
    {
        return fmax(Rf_dcauchy(eta, 0.0, 1.0, 0), DBL_EPSILON);
    }

private:
    const double thresh;
};

// ***************************************************************************************************//

// the Probit link class
class ProbitLink : public Link
{
public:
    // ctr
    ProbitLink() :
        thresh(- Rf_qnorm5(DBL_EPSILON, 0.0, 1.0, 1, 0))
        {
        }

    // probit == normal quantile
    double
    linkfun(double mu) const
    {
        return Rf_qnorm5(mu, 0.0, 1.0, 1, 0);
    }

    // inverse probit == normal cdf
    // compare in R: binomial("probit")$linkinv
    double
    linkinv(double eta) const
    {
        eta = fmin(fmax(eta, - thresh), thresh);
        return Rf_pnorm5(eta, 0.0, 1.0, 1, 0);
    }

    // normal density
    double
    mu_eta(double eta) const
    {
        return fmax(Rf_dnorm4(eta, 0.0, 1.0, 0), DBL_EPSILON);
    }

private:
    const double thresh;
};

// ***************************************************************************************************//

// the complementary log-log link class
class CloglogLink : public Link
{
public:
    // cloglog
    double
    linkfun(double mu) const
    {
        return log(- log(1.0 - mu));
    }

    // compare in R: binomial("cloglog")$linkinv
    double
    linkinv(double eta) const
    {
        return fmax(fmin(- expm1(- exp(eta)), 1 - DBL_EPSILON), DBL_EPSILON);
    }

    // compare in R: binomial("cloglog")$mu.eta
    double
    mu_eta(double eta) const
    {
        eta = fmin(eta, 700.0);
        return fmax(exp(eta) * exp(- exp(eta)), DBL_EPSILON);
    }
};

// ***************************************************************************************************//

// the inverse link class
class InverseLink : public Link
{
public:
    // inverse is the link
    double
    linkfun(double mu) const
    {
        return 1.0 / mu;
    }

    // and also the response function
    double
    linkinv(double eta) const
    {
        return 1.0 / eta;
    }

    // finally the response derivative
    double
    mu_eta(double eta) const
    {
       return - 1.0 / eta / eta;
    }
};

// ***************************************************************************************************//

// the log link class
class LogLink : public Link
{
public:
    // log is the link
    double
    linkfun(double mu) const
    {
        return log(mu);
    }

    // so the response function is exp
    double
    linkinv(double eta) const
    {
        return fmax(exp(eta), DBL_EPSILON);
    }

    // finally the response derivative is also exp
    double
    mu_eta(double eta) const
    {
        return fmax(exp(eta), DBL_EPSILON);
    }
};

// ***************************************************************************************************//

// the identity link class
class IdentityLink : public Link
{
public:
    // identity is the link ...
    double
    linkfun(double mu) const
    {
        return mu;
    }

    // ... and response function
    double
    linkinv(double eta) const
    {
        return eta;
    }

    // finally the response derivative is 1
    double
    mu_eta(double eta) const
    {
        return 1.0;
    }
};
#endif /* LINKS_H_ */

/*
 * rcppExport.h
 *
 *  Created on: 13.10.2010
 *      Author: daniel
 */

#ifndef RCPPEXPORT_H_
#define RCPPEXPORT_H_

#include <RcppCommon.h>

// load the library defining the templated class
#include <set>

// declaring the partial specialization
namespace Rcpp
{
namespace traits
{
template <typename T> class Exporter<std::set<T> >;
}
}


// this must appear after the specialization,
// otherwise the specialization will not be seen by Rcpp types
#include <RcppArmadillo.h>


// only now the implementation of the new Exporter class:
namespace Rcpp
{
namespace traits
{
template <typename T> class Exporter<std::set<T> >
{
public:
    // we need a constructor taking an SEXP
    Exporter(SEXP s) :
        _x(s)
    {
    }

    // and we need a method called "get" that returns an instance of the wished type:
    inline std::set<T>
    get()
    {
        // allocate return set
        std::set<T> x;

        // insert all elements in _x into the return set x:
        for (R_len_t i = 0; i < _x.size(); ++i)
        {
            x.insert(_x[i]);
        }

        // return the result
        return x;
    }

private:
    Rcpp::IntegerVector _x;
};
}
}


#endif /* RCPPEXPORT_H_ */

#ifndef SUM_H_
#define SUM_H_

// Source: http://oldmill.uchicago.edu/~wilder/Code/sum/

#include <cmath>
#include <vector>

using std::vector;

//========================================================================
// The condensed summation algorithm of Kahan.  Avoids common round-off
// errors in computing the sum of a bunch of numbers.  It works well for
// most cases, but can fail badly when there is cancellation.  The
// slower modified_deflation algorithm below does better in those cases.

template<class T>
    T
    condensed_summation(const vector<T>& v)
    {
        T a, b, sum = 0.0, error = 0.0;
        for (typename vector<T>::const_iterator i = v.begin(); i != v.end(); ++i)
        {
            a = sum;
            b = * i + error;
            sum = a + b;
            error = (a - sum) + b;
        }
        return sum;

    } // condensed_summation

    //========================================================================
    // The modified deflation algorithm of Anderson.  It is reasonably fast,
    // and should give the correct result as it is difficult if not impossible
    // to do better without increasing the precision of the variables.  The
    // portion of the algorithm that handles potentially infinite loops has
    // been modified as the original version did not always work in my tests.
    // I believe the failures were due to errors in g++ optimizations and
    // also believe that my code still has an error.

template<class T>
    T
    modified_deflation(const vector<T>& v)
    {
        if (v.size() < 3)
            return condensed_summation(v);

        // Set up several vectors
        vector<T> vp;
        vector<T> vn;
        vector<T> e;

        // we do not need to do this:
//        vp.reserve(v.size());
//        vn.reserve(v.size());
//        e.reserve(v.size());

        // Initialize vectors of negative and positive elements of v
        for (typename vector<T>::const_iterator
                i = v.begin();
                i != v.end();
                ++i)
            if (* i < 0.0)
                vn.push_back(* i);
            else if (* i > 0.0)
                vp.push_back(* i);


        // immediately return 0 if there are no negative or positive elements
        if(vn.empty() && vp.empty())
            return static_cast<T>(0.0);

        // now we are sure there is at least one non-zero element,
        // and can start with the summation algorithm.

        T a, b, sum, error, sp, sn;

        bool well_conditioned = false;
        while (! well_conditioned)
        {
            // Deflate the last elements of vp and vn.
            while (! vp.empty() && ! vn.empty())
            {
                a = vp.back();
                vp.pop_back();
                b = vn.back();
                vn.pop_back();
                sum = a + b;
                error = (a - sum) + b;
                if (sum == a)
                { // |a| >> |b|
                    T tmp1 = a / 2.0;
                    T tmp2 = a - tmp1;
                    vp.push_back(tmp2);
                    vp.push_back(tmp1);
                    vn.push_back(b);
                }
                else if (sum == b)
                { // |b| >> |a|
                    T tmp1 = b / 2.0;
                    T tmp2 = b - tmp1;
                    vp.push_back(a);
                    vn.push_back(tmp2);
                    vn.push_back(tmp1);
                }
                else
                {
                    if (sum < 0.0)
                        vn.push_back(sum);
                    else if (sum > 0.0)
                        vp.push_back(sum);

                    if (error != 0.0)
                        e.push_back(error);
                }
            }

            // Put the error terms back in the vp and vn arrays.
            for (typename vector<T>::iterator
                    i = e.begin();
                    i != e.end();
                    ++i)
            {
                if (* i < 0.0)
                    vn.push_back(* i);
                else if (* i > 0.0)
                    vp.push_back(* i);
            }

            e.clear();

            // Check that the sums in vp and vn are well-conditioned.
            sp = condensed_summation(vp);
            sn = condensed_summation(vn);
            well_conditioned = (std::abs((sp + sn) / (sp - sn)) == 1.0);
        }

        vector<T> vnew;
        vnew.reserve(vp.size() + vn.size());

        vnew.insert(vnew.end(), vp.begin(), vp.end());
        vnew.insert(vnew.end(), vn.begin(), vn.end());

        return condensed_summation(vnew);

    } // modified_deflation


#endif /*SUM_H_*/

/*
 * design.cpp
 *
 *  Created on: 09.11.2009
 *      Author: daniel
 */

#include "design.h"
#include "fpUcHandling.h"
#include "dataStructure.h"

#include "rcppExport.h"
#include "types.h"

#include <algorithm>


// get different concatenated columns of matrix
AMatrix
getMultipleCols(const AMatrix& m,
                const PosIntVector& s) // expect that the column numbers s are 1-based!
{
    AMatrix ret(m.n_rows, s.size());

    PosIntVector::size_type cols = 0; // invariant: about to process column nr. "cols"
    for (PosIntVector::const_iterator i = s.begin(); i != s.end(); i++)
    {
        ret.col(cols++) = m.col(*i - 1); // so we must subtract 1 here
    }

    return ret;
}


// ***************************************************************************************************//

// build Fp basis matrix from vector, power indices and power set for one covariate
AMatrix
getFpMatrix(const std::vector<AVector>& tcols,
            const Powers& powerinds,
            const DataValues& data)
{
    const int logInd = 3; // this index corresponds to power = 0, i.e. log.
    const int nrow = tcols.at(1).n_elem;

    // get the log column
    const AVector& logColumn = tcols.at(logInd);

    // this will be the returned matrix
    AMatrix ret(nrow, powerinds.size());

    // start recursion
    int lastInd = logInd;
    AVector lastCol = arma::ones<AVector>(nrow);

    // there is at least one power present
    Powers::size_type cols = 0; // invariant: about to process column number "cols"

    for (Powers::const_iterator
         now = powerinds.begin();
         now != powerinds.end();
         now++)
    {
        if (*now == lastInd)
        { // repeated powers case:

            // elementwise multiplication (Schur product):
            lastCol = lastCol % logColumn;
        }
        else
        { // normal case

            lastInd = *now;
            lastCol = tcols.at(lastInd);
        }
        // center the column
        ret.col(cols++) = lastCol - arma::mean(lastCol);
    }

    return ret;
}

// ***************************************************************************************************//

// construct centered design matrix including intercept for the model
// optionally the intercept column is not included
AMatrix
getDesignMatrix(const ModelPar &mod,
                const DataValues &data,
                const FpInfo &fpInfo,
                const UcInfo& ucInfo,
                const FixInfo& fixInfo,
                bool includeIntercept)
{
    // total number of columns
    int nColumns = mod.size(ucInfo, fixInfo); 
    if(includeIntercept)
    {
        ++nColumns;
    }

    // initialize the return matrix
    AMatrix ret(data.nObs, nColumns);

    // invariant: nextColumn is the next column to be written
    PosInt nextColumn = 0;

    // start with the intercept column?
    if(includeIntercept)
    {
        ret.col(0) = data.onesVector;
        ++nextColumn;
    }

    // go on with centered fp matrices
    for (PosInt i = 0; i != fpInfo.nFps; i++)
    {
        Powers powersi = mod.fpPars.at(i);

        if (! powersi.empty())
        {
            // what is the end column in the return matrix?
            PosInt endColumn = nextColumn + powersi.size() - 1;

            // insert the centered FP matrix into the return matrix
            ret.cols(nextColumn, endColumn) = getFpMatrix(fpInfo.tcols.at(i), powersi, data);

            // correct invariant
            nextColumn = endColumn + 1;
        }
    }

    // centered uc matrices
    for(IntSet::const_iterator
            g = mod.ucPars.begin();
            g != mod.ucPars.end();
            ++g)
    {
        // the C index is
        Int i = *g - 1;

        // what is the column list for this covariate?
        PosIntVector thisColList = ucInfo.ucColList.at(i);

        // what is the end column in the return matrix?
        PosInt endColumn = nextColumn + thisColList.size() - 1;

        // insert the centered UC matrix into the return matrix
        ret.cols(nextColumn, endColumn) = getMultipleCols(data.centeredDesign, thisColList);

        // correct invariant
        nextColumn = endColumn + 1;
    }
    
    
    // centered fix matrices
    for(IntSet::const_iterator
          g = mod.fixPars.begin();
        g != mod.fixPars.end();
        ++g)
    {
      // the C index is
      Int i = *g - 1;
      
      // what is the column list for this covariate?
      PosIntVector thisColList = fixInfo.fixColList.at(i);
      
      // what is the end column in the return matrix?
      PosInt endColumn = nextColumn + thisColList.size() - 1;
      
      // insert the centered UC matrix into the return matrix
      ret.cols(nextColumn, endColumn) = getMultipleCols(data.centeredDesign, thisColList);
      
      // correct invariant
      nextColumn = endColumn + 1;
    }
    

    return ret;
}

// ***************************************************************************************************//



// End of file.

/*
 * distributions.cpp
 *
 *  Created on: 15.03.2010
 *      Author: daniel
 *
 * Implementation of classes for exponential family distributions,
 * i.e. functions which should not be inlined by the compiler.
 *
 */

#include "distributions.h"
#include <string>
#include "types.h"
#include "rcppExport.h"

// ***************************************************************************************************//

// helper function for the binomial and Poisson loglikelihood
// see R/src/library/stats/src/family.c for the original R source code.
static inline double
y_log_y(double y, double mu)
{
    return (y > 0.0) ? (y * log(y / mu)) : 0.0;
}

// ***************************************************************************************************//


// binomial loglikelihood
// compare in R: binomial()$dev.resids
double
Binomial::loglik(const double *means) const
{
    double ret = 0.0;

    for(PosInt i = 0; i < responses.n_elem; ++i, ++means)
    {
        ret += weights(i) * (y_log_y(responses(i), *means) + y_log_y(1.0 - responses(i), 1.0 - *means));
    }

    return - ret;
}

// ***************************************************************************************************//


// Gaussian loglikelihood
// compare in R: poisson()$dev.resids
double
Gaussian::loglik(const double *means) const
{
    double ret = 0.0;

    for(PosInt i = 0; i < responses.n_elem; ++i, ++means)
    {
        ret += weights(i) * (responses(i) - *means) * (responses(i) - *means);
    }

    return - 0.5 * ret / phi;
}

// ***************************************************************************************************//


// Poisson loglikelihood
// compare in R: poisson()$dev.resids
double
Poisson::loglik(const double *means) const
{
    double ret = 0.0;

    for(PosInt i = 0; i < responses.n_elem; ++i, ++means)
    {
        ret += weights(i) * (responses(i) - *means - y_log_y(responses(i), *means));
    }

    return ret;
}

/*
 * evalZdensity.cpp
 *
 *  Created on: 16.05.2010
 *      Author: daniel
 */


#include "rcppExport.h"
#include "dataStructure.h"
#include "types.h"
#include "zdensity.h"
#include "fpUcHandling.h"
#include <stdexcept>

using namespace Rcpp;

// ***************************************************************************************************//


// R call is:
//
//    samples <- .External(cpp_evalZdensity,
//                         config,
//                         attrs$data,
//                         attrs$fpInfos,
//                         attrs$ucInfos,
//                         attrs$fixInfos,
//                         attrs$distribution,
//                         options)
// [[Rcpp::export]]
SEXP
cpp_evalZdensity(List rcpp_config, List rcpp_data, List rcpp_fpInfos, List rcpp_ucInfos,
                List rcpp_fixInfos, List rcpp_distribution, List rcpp_options)
{
    // ----------------------------------------------------------------------------------
    // extract arguments
    // ----------------------------------------------------------------------------------

    // r_interface = CDR(r_interface);
    // List rcpp_config(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_data(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_fpInfos(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_ucInfos(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_fixInfos(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_distribution(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_options(CAR(r_interface));

    // ----------------------------------------------------------------------------------
    // unpack the R objects
    // ----------------------------------------------------------------------------------

    // data:

    const NumericMatrix n_x = rcpp_data["x"];
    const AMatrix x(n_x.begin(), n_x.nrow(),
                   n_x.ncol());

    const NumericMatrix n_xCentered = rcpp_data["xCentered"];
    const AMatrix xCentered(n_xCentered.begin(), n_xCentered.nrow(),
                           n_xCentered.ncol());

    const NumericVector n_y = rcpp_data["y"];
    const AVector y(n_y.begin(), n_y.size());

    const IntVector censInd = as<IntVector>(rcpp_data["censInd"]);

    // FP configuration:

    // vector of maximum fp degrees
    const PosIntVector fpmaxs = as<PosIntVector>(rcpp_fpInfos["fpmaxs"]);
    // corresponding vector of fp column indices
    const PosIntVector fppos = rcpp_fpInfos["fppos"];
    // corresponding vector of power set cardinalities
    const PosIntVector fpcards = rcpp_fpInfos["fpcards"];
    // names of fp terms
    const StrVector fpnames = rcpp_fpInfos["fpnames"];


    // UC configuration:

    const PosIntVector ucIndices = rcpp_ucInfos["ucIndices"];
    List rcpp_ucColList = rcpp_ucInfos["ucColList"];

    std::vector<PosIntVector> ucColList;
    for (R_len_t i = 0; i != rcpp_ucColList.length(); ++i)
    {
        ucColList.push_back(as<PosIntVector>(rcpp_ucColList[i]));
    }

    // fixed covariate configuration:
    
    const PosIntVector fixIndices = rcpp_fixInfos["fixIndices"];
    List rcpp_fixColList = rcpp_fixInfos["fixColList"];
    
    std::vector<PosIntVector> fixColList;
    for (R_len_t i = 0; i != rcpp_fixColList.length(); ++i)
    {
      fixColList.push_back(as<PosIntVector>(rcpp_fixColList[i]));
    }
    

    // distributions info:

    const double nullModelLogMargLik = as<double>(rcpp_distribution["nullModelLogMargLik"]);
    const double nullModelDeviance = as<double>(rcpp_distribution["nullModelDeviance"]);
    const double empiricalMean = as<double>(rcpp_distribution["yMean"]);
    S4 rcpp_gPrior = rcpp_distribution["gPrior"];
    List rcpp_family = rcpp_distribution["family"];



    // options:

    const MyDoubleVector zValues = rcpp_options["zValues"];
//    const bool conditional = as<bool>(rcpp_options["conditional"]);
//    const bool debug = as<bool>(rcpp_options["debug"]);
//    const bool higherOrderCorrection = as<bool>(rcpp_options["higherOrderCorrection"]);

    const Book bookkeep(as<bool>(rcpp_distribution["tbf"]),
                        as<bool>(rcpp_distribution["doGlm"]),
                        false,
                        as<bool>(rcpp_options["conditional"]),
                        false, //useFixedc
                        100,
                        false,
                        as<bool>(rcpp_options["debug"]),
                        as<std::string>(rcpp_distribution["modelPrior"]),
                        10,
                        10,
                        10,
                        false,
                        as<bool>(rcpp_options["debug"]),
                        as<bool>(rcpp_options["higherOrderCorrection"]));


    // ----------------------------------------------------------------------------------
    // further process arguments
    // ----------------------------------------------------------------------------------

    // data:

     // only the intercept is always included, that is fixed, in the model
     IntSet fixedCols;
     fixedCols.insert(1);

     // totalnumber is set to 0 because we do not care about it.
     const DataValues data(x, xCentered, y, censInd, 0, fixedCols);

     // FP configuration:
     const FpInfo fpInfo(fpcards, fppos, fpmaxs, fpnames, x);

     // UC configuration:

     // determine sizes of the UC groups, and the total size == maximum size reached together by all
     // UC groups.
     PosIntVector ucSizes;
     PosInt maxUcDim = 0;
     for (std::vector<PosIntVector>::const_iterator cols = ucColList.begin(); cols != ucColList.end(); ++cols)
     {
         PosInt thisSize = cols->size();

         maxUcDim += thisSize;
         ucSizes.push_back(thisSize);
     }
     const UcInfo ucInfo(ucSizes, maxUcDim, ucIndices, ucColList);

     
     
     
     // fix configuration:   //TODO THIS SECTION
     
     // determine sizes of the fix groups, and the total size == maximum size reached together by all
     // fix groups.
     PosIntVector fixSizes;
     PosInt maxFixDim = 0;
     for (std::vector<PosIntVector>::const_iterator cols = fixColList.begin(); cols != fixColList.end(); ++cols)
     {
       PosInt thisSize = cols->size();
       
       maxFixDim += thisSize;
       fixSizes.push_back(thisSize);
     }
     const FixInfo fixInfo(fixSizes, maxFixDim, fixIndices, fixColList);
     
     
     // search configuration:
     const GlmModelConfig config(rcpp_family, nullModelLogMargLik, nullModelDeviance, as<double>(rcpp_distribution["fixedg"]), rcpp_gPrior,
                                 data.response, bookkeep.debug, bookkeep.useFixedc, empiricalMean, 
                                 as<bool>(rcpp_distribution["empiricalgPrior"]));
     // config of this model:
     const ModelPar thisModelConfig(rcpp_config, fpInfo);


     // ----------------------------------------------------------------------------------
     // evaluate the z density
     // ----------------------------------------------------------------------------------

     // get negative log unnormalized z density: a function object.
     NegLogUnnormZDens negLogUnnormZDens(thisModelConfig,
                                         data,
                                         fpInfo,
                                         ucInfo,
                                         fixInfo,
                                         config,
                                         bookkeep);

     // evaluate it at the given z values.
     NumericVector results;

     for (MyDoubleVector::const_iterator z = zValues.begin(); z != zValues.end(); ++z)
     {
         results.push_back(negLogUnnormZDens(* z));
     }

     // return the results vector
     return results;
}

/*
 * fpUcHandling.h
 *
 *  Created on: 09.11.2009
 *      Author: daniel
 */

#ifndef FPUCHANDLING_H_
#define FPUCHANDLING_H_

#include "types.h"
#include <numeric>
#include "rcppExport.h"

// ***************************************************************************************************//

// small helper function to structure code:
// get the maximum power set for a range of FP maximum degrees
MyDoubleVector
getMaxPowerSet(const PosIntVector& fpmaxs);

// ***************************************************************************************************//

// build array of vectors of ColumnVectors holding the required transformed values for the design matrices
// do not! center the column. This is done inside getFpMatrix, because the repeated powers case cannot
// be treated here.
AVectorArray
getTransformedCols(const PosIntVector& fpcards,
                   const PosIntVector& fppos,
                   const PosIntVector& fpmaxs,
                   const AMatrix& x);


// ***************************************************************************************************//


struct FpInfo
{ // collects all information on fractional polynomials needed to be passed down
    PosInt nFps;
    MyDoubleVector powerset;
    PosIntVector fpcards;
    PosIntVector fppos;
    PosIntVector fpmaxs;
    StrVector fpnames;
    AVectorArray tcols;
    PosInt maxFpDim;

    // number of possible univariate fps for each FP?
    IntVector numberPossibleFps;

    // what is the multiset expressing a linear inclusion of a covariate?
    Powers linearPowers;


    // ctr
    FpInfo(const PosIntVector& fpcards,
           const PosIntVector& fppos,
           const PosIntVector& fpmaxs,
           const StrVector& fpnames,
           const AMatrix& x) :
        nFps(fpmaxs.size()), powerset(getMaxPowerSet(fpmaxs)), fpcards(fpcards),
                fppos(fppos), fpmaxs(fpmaxs), fpnames(fpnames), tcols(getTransformedCols(fpcards, fppos, fpmaxs, x)),
                maxFpDim(std::accumulate(fpmaxs.begin(), fpmaxs.end(), 0)),
                numberPossibleFps(),
                linearPowers()
    {
        // numbers of possible univariate fps?
        for(PosInt i=0; i != nFps; ++i)
        {
            int thisNumber = 0;
            for(PosInt deg = 0; deg <= fpmaxs[i]; ++deg)
            {
                thisNumber += Rf_choose(fpcards[i] - 1 + deg, deg);
            }
            numberPossibleFps.push_back(thisNumber);
        }

        // insert the index 5 for linear power 1
        linearPowers.insert(5);

    }

    // convert inds m into powers vector
    MyDoubleVector
    inds2powers(const Powers& m) const;

    // convert std::vector of powers into Powers object (i.e. a multiset)
    Powers
    vec2inds(const MyDoubleVector& p) const;

};

// ***************************************************************************************************//

// collects all information on uncertain fixed form covariates groups
struct UcInfo
{
    const PosIntVector ucSizes;
    const PosInt maxUcDim;
    const PosIntVector ucIndices;
    const std::vector <PosIntVector> ucColList;
    const PosInt nUcGroups;

    UcInfo(const PosIntVector& ucSizes,
           const PosInt maxUcDim,
           const PosIntVector& ucIndices,
           const std::vector<PosIntVector>& ucColList) :
        ucSizes(ucSizes), maxUcDim(maxUcDim), ucIndices(ucIndices),
                ucColList(ucColList), nUcGroups(ucColList.size())
    {
    }
};

// ***************************************************************************************************//

// collects all information on fixed form covariates groups
struct FixInfo
{
	const PosIntVector fixSizes;
	const PosInt maxFixDim;
	const PosIntVector fixIndices;
	const std::vector <PosIntVector> fixColList;
	const PosInt nFixGroups;

	FixInfo(const PosIntVector& fixSizes,
		const PosInt maxFixDim,
		const PosIntVector& fixIndices,
		const std::vector<PosIntVector>& fixColList) :
		fixSizes(fixSizes), maxFixDim(maxFixDim), fixIndices(fixIndices),
		fixColList(fixColList), nFixGroups(fixColList.size())
	{
	}
};

// ***************************************************************************************************//


// return iterator of random element of myset; should be enclosed in getRNGstate() etc.
template<class T>
    typename T::iterator
    discreteUniform(const T& container)
    {
        if (container.empty())
        {
            Rf_error("\ncontainer in call to discreteUniform is empty!\n");
        }

        double u = unif_rand();

        typename T::size_type size = container.size();
        typename T::const_iterator i = container.begin();
        typename T::size_type j = 1;

        while (u > 1.0 / size * j)
        {
            i++;
            j++;
        }

        return i;
    }

// ***************************************************************************************************//

// get random int x with lower <= x < upper; should be enclosed in getRNGstate() etc.
template<class INT>
INT
discreteUniform(const INT& lower, const INT& upper)
{
    if (lower >= upper)
    {
        Rf_error("\nlower = %d >= %d = upper in discreteUniform call\n", lower,
                 upper);
    }

    double u = unif_rand();

    INT size = upper - lower;
    INT ret = lower;

    while (u > 1.0 / size * (ret - lower + 1))
    {
        ret++;
    }

    return ret;
}

// ***************************************************************************************************//


// delete a number from a set
template<class T>
    typename std::set<T>
    removeElement(std::set<T> input, T element)
    {
        typename std::set<T>::iterator iter = input.begin();
        while (iter != input.end())
        {
            if (*iter == element)
                // A copy of iter is passed into erase(), ++ is executed after erase().
                // Thus iter remains valid
                input.erase(iter++);
            else
                ++iter;
        }

        return input;
    }

// ***************************************************************************************************//

// construct a sequence 1:maximum
template<class T>
    typename std::set<T>
    constructSequence(T maximum)
    {
        std::set<T> ret;

        for (T i = 1; i <= maximum; ++i)
        {
            ret.insert(ret.end(), i);
        }

        return ret;
    }

// ***************************************************************************************************//

// convert frequency vector into multiset
Powers
freqvec2Powers(IntVector& vec, const int &vecLength);

// ***************************************************************************************************//


#endif /* FPUCHANDLING_H_ */

/*
 * zdensity.h
 *
 *  Created on: 16.11.2009
 *      Author: daniel
 */

#ifndef ZDENSITY_H_
#define ZDENSITY_H_

#include "iwls.h"
#include "coxfit.h"
#include "types.h"

// 21/11/2012: major update due to inclusion of TBF methodology

class NegLogUnnormZDens {
public:

    // call the function object:
    // z is the argument,
    double
    operator()(double z);

    // constructor
    NegLogUnnormZDens(const ModelPar &mod,
                      const DataValues& data,
                      const FpInfo& fpInfo,
                      const UcInfo& ucInfo,
                      const FixInfo& fixInfo,
                      const GlmModelConfig& config,
                      // return the approximate *conditional* density f(y | z, mod) by operator()?
                      // otherwise return the approximate unnormalized *joint* density f(y, z | mod).
                      const Book& bookkeep,
                      PosInt nIter=40);

    // try to get the TBF log marginal likelihood
    double
    getTBFLogMargLik() const;

    // get the maximum log conditional marginal likelihood
    // and put the local EB estimate into zMode
    double
    getTBFMaxLogCondMargLik(double& zMode) const;

    // get residual deviance
    double
    getResidualDeviance() const
    {
        return modResidualDeviance;
    }

    // destructor
    ~NegLogUnnormZDens()
    {
        delete iwlsObject;
        delete coxfitObject;
    }

private:
    // save the model reference and fp info, so we can write a nice warning message if the
    // IWLS fails for some z
    const ModelPar& mod;
    const FpInfo& fpInfo;
    const GlmModelConfig& config;
    const Book& bookkeep;

    // also save the original start linear predictor
    const AVector linPredStart;

    // pointer to an IWLS object
    Iwls * iwlsObject;

    // pointer to a Coxfit object
    Coxfit * coxfitObject;

    // number of IWLS iterations
    PosInt nIter;

    // the size of the model
    const int modSize;

    // the residual deviance of the model (only filled with correct value if TBF approach is used)
    double modResidualDeviance;
};


#endif /* ZDENSITY_H_ */

/*
 * fpUcHandling.cpp
 *
 *  Created on: 09.11.2009
 *      Author: daniel
 *      
 *  13/07/2015 Replace assert() with Rccp:Stop()
 */

#include "fpUcHandling.h"

//#include <cassert>
#include <algorithm>

#include "rcppExport.h"

// ***************************************************************************************************//

// small helper function to structure code:
// get the maximum power set for a range of FP maximum degrees
MyDoubleVector
getMaxPowerSet(const PosIntVector& fpmaxs)
{
    // always in the power set:
    static const double fixedpowers[] = { -2, -1, -0.5, 0, 0.5, 1, 2, 3 };
    //        corresponding indices        0   1     2  3    4  5  6  7

    // convert to double vector
    MyDoubleVector maxPowerset(fixedpowers, fixedpowers + 8);

    if (! fpmaxs.empty())
    {
        // consider if the power set is even bigger
        const PosInt biggestMaxDegree = * std::max_element(fpmaxs.begin(),
                                                           fpmaxs.end());
        for (PosInt more = 4; more <= biggestMaxDegree; ++more)
        {
            maxPowerset.push_back(more);
        }
    }

    // return the maximum power "set"
    return (maxPowerset);
}


// ***************************************************************************************************//

// fpInfo //

MyDoubleVector
FpInfo::inds2powers(const Powers& m) const // convert inds m (a "Powers" object) into powers vector p (a MyDoubleVector)
{
    MyDoubleVector ret;

    for (Powers::const_iterator j = m.begin();
            j != m.end();
            j++)
    {
        ret.push_back(powerset[*j]);
    }

    return ret;
}


// convert std::vector of powers into Powers object (i.e. a multiset) of ints of the power indexes.
Powers
FpInfo::vec2inds(const MyDoubleVector& p) const
{
    Powers ret;

    for(MyDoubleVector::const_iterator j = p.begin();
            j != p.end();
            j++)
    {
        // the index which we look for is the difference of the start of the powerset and the
        // iterator pointing to the location where the power was found.
        int index = find(powerset.begin(), powerset.end(), *j) - powerset.begin();
        ret.insert(index);
    }

    return ret;
}

// ***************************************************************************************************//


// Box-Tidwell transform
static inline double
boxtidwell(double x, double power)
{
    return (power != 0) ? pow(x, power) : log(x);
}

// ***************************************************************************************************//

// build array of vectors of AVectors holding the required transformed values for the design matrices
// do not! center the column. This is done inside getFpMatrix, because the repeated powers case cannot
// be treated here!!
AVectorArray
getTransformedCols(const PosIntVector& fpcards,
                   const PosIntVector& fppos,
                   const PosIntVector& fpmaxs,
                   const AMatrix& x)
{
    // initialize the return value
    AVectorArray transformedCols;

    // get maximum powerset
    MyDoubleVector maxPowerset = getMaxPowerSet(fpmaxs);

    // process each FP term
    PosIntVector::const_iterator card = fpcards.begin();
    for (PosIntVector::const_iterator pos = fppos.begin(); pos != fppos.end(); ++card, ++pos)
    {
        // the original column
        const AVector thisCol = x.col(*pos - 1);

        // start vector of columns for this FP term
        std::vector<AVector> thisFp;

        // for every possible power
        for (PosInt j = 0; j != *card; j++)
        {
            // start with original column
            AVector thisTransform = thisCol;

            // then transform it according to the power:
            for (PosInt k = 0; k < thisTransform.n_rows; ++k)
            {
                // assert(thisTransform(k) > 0);
              if(!(thisTransform(k) > 0)) Rcpp::stop("fpUcHandling.cpp:getTransformedCols: thisTransform(k) not greater than 0");

                thisTransform(k) = boxtidwell(thisTransform(k),
                                              maxPowerset[j]);

                // assert(! ISNAN(thisTransform(k)));
                if(ISNAN(thisTransform(k))) Rcpp::stop("fpUcHandling.cpp:getTransformedCols: thisTransform(k) is NAN");
            }

            // and put it into vector of columns
            thisFp.push_back(thisTransform);
        }

        // push vector of all powers for this FP term into the array
        transformedCols.push_back(thisFp);
    }

    // return the array
    return (transformedCols);
}

// ***************************************************************************************************//


// convert frequency vector into multiset
Powers
freqvec2Powers(IntVector& vec, const int &vecLength)
{
    Powers ret;
    for (int power = 0; power != vecLength; power++)
    {
        for (int times = 0; times != vec[power]; times++)
            ret.insert(power);
    }
    return ret;
}

// ***************************************************************************************************//

// End of file.

/*
 * functionWraps.cpp
 *
 *  Created on: 06.11.2009
 *      Author: daniel
 */

#include "functionWraps.h"
#include "rcppExport.h"

using namespace Rcpp;

// ***************************************************************************************************//

// first R functions taking only a scalar

//// constructor
//RFunction::RFunction(SEXP R_fun)
//{
//    // allocate double scalar as function argument
//    Rf_protect(R_functionArgument = Rf_allocVector(REALSXP, 1));
//
//    // construct the function call
//    Rf_protect(R_functionCall = Rf_lcons(R_fun,
//                                  Rf_lcons(R_functionArgument,
//                                     R_NilValue)));
//
//    // get the function frame (is connected to the R function, so is already protected)
//    R_functionFrame = FRAME(R_fun);
//}

//// copy constructor
//RFunction::RFunction(const RFunction& old)
//{
//    // double scalar as function argument:
//    // take the same one as the old object.
//    Rf_protect(R_functionArgument = old.R_functionArgument);
//
//    // so also for the function call we must take the same one
//    Rf_protect(R_functionCall = old.R_functionCall);
//
//    // and then finally get the function frame
//    R_functionFrame = old.R_functionFrame;
//}


//// assignment operator
//RFunction& RFunction::operator=(const RFunction& rhs)
//{
//    if(&rhs != this)
//    {
//        // first unprotect the current members
//        Rf_unprotect(3);
//
//        // then assign the new members:
//
//        // double scalar as function argument:
//        // take the same one as the old object.
//        Rf_protect(R_functionArgument = rhs.R_functionArgument);
//
//        // so also for the function call we must take the same one
//        Rf_protect(R_functionCall = rhs.R_functionCall);
//
//        // and then finally get the function frame
//        R_functionFrame = rhs.R_functionFrame;
//    }
//
//    // return ourself
//    return *this;
//}
//

//// destructor
//RFunction::~RFunction()
//{
//    // unprotect the the function argument and the call
//    Rf_unprotect(2);
//
//    // everything else is automatically destroyed.
//}

// for use as a function
double
RFunction::operator()(double x) const
{
//    // input the argument
//    REAL(R_functionArgument)[0] = x;

//    // get the result
//    SEXP R_pars;
//    Rf_protect(R_pars = Rf_eval(R_functionCall,
//                                R_functionFrame));
//
//    // now convert to double vector
//    double ret = Rf_asReal(Rf_coerceVector(R_pars, REALSXP));
//
//    // unprotect local R result
//    Rf_unprotect(1);
//
//    // and return that
//    return ret;

    // shorter:
    // 8/11/2013: debug error
    // "'rho' must be an environment not pairlist: detected in C-level eval"
    // In gdb I find the following "classes" for the arguments:
    // (see Rinternals.h, line 98 ff.)

    double ret = as<double>(fun(x));
    return ret;

//    return Rf_asReal(Rf_coerceVector(Rf_eval(R_functionCall, // SEXP type 6: language constructs
//                                             R_functionFrame), // SEXP type 2: lists of dotted pairs
//                                     REALSXP));
}

// ***************************************************************************************************//


// now R functions taking a fixed length vector


//// constructor
//VectorRFunction::VectorRFunction(SEXP R_function, R_len_t argsize) :
//        argsize(argsize)
//{
//    // allocate vector as function argument
//    Rf_protect(R_functionArgument = Rf_allocVector(REALSXP, argsize));
//
//    // construct the function call
//    Rf_protect(R_functionCall = Rf_lcons(R_function,
//                                  Rf_lcons(R_functionArgument,
//                                     R_NilValue)));
//
//    // get the function frame (is connected to the R function, so is already protected)
//    R_functionFrame = FRAME(R_function);
//}
//
//
//// destructor
//VectorRFunction::~VectorRFunction()
//{
//    // unprotect the function argument and call
//    Rf_unprotect(2);
//
//    // everything else is automatically destroyed.
//}

// for use as a function
double
VectorRFunction::operator()(const double* vector) const
{
    // copy the vector
    NumericVector arg(argsize);
    std::copy(vector, vector + argsize, arg.begin());

    // and then evaluate the function call.
    double ret = as<double>(fun(arg));
    return ret;
}


// ***************************************************************************************************//

// save one pair of argument and function value
void
Cache::save(double arg, double val)
{
    args.push_back(arg);
    vals.push_back(val);
}

// clear the cache
void
Cache::clear()
{
    args.clear();
    vals.clear();
}

// query for a function value
double
Cache::getValue(double arg) const
{
    // search for the argument
    MyDoubleVector::const_iterator iterVals = vals.begin();
    for(MyDoubleVector::const_iterator
            iterArgs = args.begin();
            iterArgs != args.end();
            ++iterArgs, ++iterVals)
    {
        // match -> return corresponding value.
        if(*iterArgs == arg)
        {
            return *iterVals;
        }
    }

    // if we have not found the argument, return NA
    return R_NaReal;
}

// initialize from an R list
Cache::Cache(List& rcpp_list) :
        args(as<MyDoubleVector>(rcpp_list["args"])),
        vals(as<MyDoubleVector>(rcpp_list["vals"]))
{
    if(args.size() != vals.size())
    {
        Rf_error("Lengths of args and vals vectors in R list converted to Cache object not equal!");
    }
}

// convert to an Rcpp list
List
Cache::convert2list() const
{
    return List::create(_["args"] = getArgs(),
                        _["vals"] = getVals());
}


// ***************************************************************************************************//

// End of file.

#include "rcppExport.h"
#include "combinatorics.h"
#include "dataStructure.h"
#include "types.h"
#include "zdensity.h"
#include "bfgs.h"
#include "optimize.h"
#include "fpUcHandling.h"

#ifdef _OPENMP
#include <omp.h>
#endif

#include <math.h>
#include <map>
#include <vector>
#include <algorithm>
#include <iterator>
#include <numeric>
#include <iostream>
#include <climits>
#include <cmath> // for the long double overloading of exp and log
#include <sstream>
#include <string>
#include <stdexcept>

// using pretty much:
using std::map;
using std::set;
using std::vector;
using std::accumulate;
using std::find;
using std::set_difference;
using std::count;
using std::max_element;

using namespace Rcpp;

// ***************************************************************************************************//

// compute varying part of log marginal likelihood for specific GLM / Cox model
// plus byproducts.
double
getGlmVarLogMargLik(const ModelPar &mod,
                    const DataValues& data,
                    const FpInfo& fpInfo,
                    const UcInfo& ucInfo,
                    const FixInfo& fixInfo,
                    const Book& bookkeep,
                    const GlmModelConfig& config,
                    const GaussHermite& gaussHermite,
                    Cache& cache,
                    double& zMode,
                    double& zVar,
                    double& laplaceApprox,
                    double& residualDeviance)
{
    // echo detailed progress in debug mode
    if(bookkeep.debug)
    {
        Rprintf("\ngetGlmVarLogMargLik: Starting log marginal likelihood approximation for:\n%s", mod.print(fpInfo).c_str());
    }

    // check if any interrupt signals have been entered
    R_CheckUserInterrupt();

    // the return value will be placed in here:
    double ret = 0.0;

    // protect everything for problems in IWLS
    try
    {
        // get negative log unnormalized z density: a function object.
        NegLogUnnormZDens negLogUnnormZDens(mod,
                                            data,
                                            fpInfo,
                                            ucInfo,
                                            fixInfo,
                                            config,
                                            bookkeep);
        residualDeviance = negLogUnnormZDens.getResidualDeviance();

        // try to ask for analytic solutions in the TBF case
        // (they are available for the incomplete inverse gamma hyperprior and of course
        // for the fixed g case)
        if(bookkeep.tbf)
        {
            if(bookkeep.debug)
            {
                Rprintf("\ngetGlmVarLogMargLik: TBF used, ask for analytic solution ...");
            }

            if(bookkeep.useFixedg)
            {
                zMode = log(config.fixedg);
                ret = - negLogUnnormZDens(zMode);

                if(bookkeep.debug)
                {
                    Rprintf("\ngetGlmVarLogMargLik: using fixed value g = %f", config.fixedg);
                }
            }
            else if(bookkeep.empiricalBayes)
            {
                ret = negLogUnnormZDens.getTBFMaxLogCondMargLik(zMode);

                if(bookkeep.debug)
                {
                    Rprintf("\ngetGlmVarLogMargLik: local empirical Bayes estimate of g is %f", exp(zMode));
                }
            }
            else
            {
                ret = negLogUnnormZDens.getTBFLogMargLik();
            }

            if(! R_IsNA(ret))
            {
                if(bookkeep.debug)
                {
                    Rprintf("\ngetGlmVarLogMargLik: analytic solution was found with result %f", ret);
                }
                return ret;
            }
            else
            {
                if(bookkeep.debug)
                {
                    Rprintf("\ngetGlmVarLogMargLik: no analytic solution possible for this hyperprior on g");
                }
            }

            // if no analytic solutions are available, we continue with the code below
        }

        // cache this function, because we do not want to evaluate it more often
        // than necessary.
        CachedFunction<NegLogUnnormZDens> cachedNegLogUnnormZDens(negLogUnnormZDens);

        if(bookkeep.useFixedg)
        {
            zMode = log(config.fixedg);

            // echo detailed progress in debug mode
            if(bookkeep.debug)
            {
                Rprintf("\ngetGlmVarLogMargLik: returning conditional marginal likelihood at fixed z = %f", zMode);
            }

            // return the log conditional marginal density log f(y | zfixed)
            ret = - cachedNegLogUnnormZDens(zMode);
        }
        else if(bookkeep.empiricalBayes)
        {
            // construct an appropriate object for using the optimize routine
            Brent<CachedFunction<NegLogUnnormZDens> > brent(cachedNegLogUnnormZDens,
                                                            -20,//-100.0, // log(DBL_MIN) + 40.0,
                                                            20,//+200.0, // log(DBL_MAX) - 40.0,
                                                            sqrt(EPS));
          
          // for(int zz = -55; zz < 40; zz=zz+2){
          //   Rcpp::Rcout << zz<< " : "<< cachedNegLogUnnormZDens(zz) << std::endl;
          // }
            // and get the mode from that.
            zMode = brent.minimize();

          // Rcpp::Rcout <<  "Zmode is : "<< zMode << std::endl;
          
            // zVar and laplaceApprox are not touched, as they are not needed!

            // echo detailed progress in debug mode
            if(bookkeep.debug)
            {
                Rprintf("\ngetGlmVarLogMargLik: finished optimization of conditional marginal likelihood at mode %f", zMode);
            }

            // return the log conditional marginal density log f(y | z_mode)
            ret = - cachedNegLogUnnormZDens(zMode);
        }
        else // start full Bayes
        {
            // get function invHess to compute an accurate variance estimate
            AccurateNumericInvHessian<CachedFunction<NegLogUnnormZDens> > invHess(cachedNegLogUnnormZDens);

            // decide if bfgs, or optimize should be used
            if(bookkeep.useBfgs)
            {
                // and run the minimization algorithm on it.

                // constrain z to lie in the interval [log(DBL_MIN), log(DBL_MAX)], so
                // that g = exp(z) is always in [DBL_MIN, DBL_MAX].
                // and we put a little safety margin on it.

                // 18/05: test a bit more realistic interval (+-200)
                // 08/07: even further shorten the interval to -100, 200 because the posterior
                //        will be very flat below z=-100
                Bfgs<CachedFunction<NegLogUnnormZDens> > bfgs(cachedNegLogUnnormZDens,
                                                              bookkeep.debug,
                                                              -100.0, // log(DBL_MIN) + 40.0,
                                                              +200.0); //log(DBL_MAX) - 40.0);

                // now minimize the negative log density,
                // and put the resulting mode into zMode.
                int convergence = bfgs.minimize(0.0,
                                                zMode,
                                                zVar);

                // if we lost precision, do a second minimization starting from the previous mode
                // and estimate the variance afterwards separately (otherwise the variance estimate
                // would not be reliable!)
                if(convergence == -1)
                {
                    bfgs.minimize(zMode,
                                  zMode,
                                  zVar);
                    zVar = invHess(zMode);
                }
            }
            else // use optimize
            {
                // construct an appropriate object for using the optimize routine
                Brent<CachedFunction<NegLogUnnormZDens> > brent(cachedNegLogUnnormZDens,
                                                                -100.0, // log(DBL_MIN) + 40.0,
                                                                +200.0, // log(DBL_MAX) - 40.0,
                                                                sqrt(EPS));
                // and get the mode from that.
                zMode = brent.minimize();

                // here we have to compute the inverse hessian afterwards:
                // use the same epsilon here as for the minimization routine.
                zVar = invHess(zMode);
            }

            // be careful that the result for zVar is not totally wrong.
            // if the variance estimate is very large, warn the user.
            if(zVar > bookkeep.largeVariance)
            {
                Rf_warning("\nLarge variance estimate (%f > %f) for z marginal encountered by BFGS",
                           zVar, bookkeep.largeVariance);
            }

            // since we minimize here the negative log density, the resulting inverse
            // hessian is the estimated variance of the approximating Gaussian.

            // be sure that we get a positive variance estimate
            if(zVar <= 0.0)
            {
                // warn
                Rf_warning("\nNon-positive variance estimate %f encountered!\nProbably the optimization did not converge.\nResetting to default variance",
                           zVar);

                // set large default to explore some space
                zVar = 15.0;
            }

            // echo detailed progress in debug mode
            if(bookkeep.debug)
            {
                Rprintf("\ngetGlmVarLogMargLik: finished minimization at mode %f with variance %f", zMode, zVar);
            }

            // compute the Laplace approximation to the log marginal likelihood from the mode and variance
            laplaceApprox = M_LN_SQRT_2PI + 0.5 * log(zVar) - cachedNegLogUnnormZDens(zMode);
            // so this does not require evaluations inside the Gauss-Hermite quadrature.

            // then compute the Gauss-Hermite quadrature, using the supplied standard nodes and
            // weights from R
            MyDoubleVector nodes;
            MyDoubleVector logWeights;

            // get the nodes and log weights for this mode and variance:
            gaussHermite.getNodesAndLogWeights(zMode, zVar, nodes, logWeights);

            // the log contributions which will be stored here:
            SafeSum logContributions;

            // compute them now
            MyDoubleVector::const_iterator n = nodes.begin();
            for(MyDoubleVector::const_iterator
                    w = logWeights.begin();
                    w != logWeights.end();
                    ++w, ++n)
            {
                logContributions.add((*w) - cachedNegLogUnnormZDens(*n));
            }

            // the result is the log of the sum of the exp'ed values
            ret = logContributions.logSumExp();
        } // end full Bayes

        // echo detailed progress in debug mode
        if(bookkeep.debug)
        {
            Rprintf("\ngetGlmVarLogMargLik: finished log marginal likelihood approximation.");
        }

        // also give back the cache
        cache = cachedNegLogUnnormZDens.getCache();

        // check finiteness
        if (! R_finite(ret))
        {
            std::ostringstream stream;
            stream << "getGlmVarLogMargLik got non-finite log marginal likelihood approximation " << ret;
            throw std::domain_error(stream.str().c_str());
        }
    }
    catch (std::domain_error& error)
    {
        if(bookkeep.debug)
        {
            Rprintf("\ngetGlmVarLogMargLik: Model can not be included, because\n%s", error.what());
        }

        return R_NaN;
    }

    // only then return the estimate
    return ret;
}

// ***************************************************************************************************//

// compute varying part of logarithm of model prior
double
getVarLogPrior(
               const ModelPar &mod,
               const FpInfo &fpInfo,
               const UcInfo &ucInfo,
               const FixInfo& fixInfo,
               const Book &bookkeep)
{
    if (bookkeep.modelPrior == "sparse")
    {
        SafeSum thisVarLogPrior;
        for (unsigned int i = 0; i != fpInfo.nFps; i++)
        { // for each fp covariate
            unsigned int degree = mod.fpPars.at(i).size();
            double thisVal = -Rf_lchoose(fpInfo.fpcards[i] - 1 + degree, degree)
                    - log1p(fpInfo.fpmaxs[i]);
            thisVarLogPrior.add(thisVal);
        }
        return thisVarLogPrior.sum() - ((ucInfo.nUcGroups + fixInfo.nFixGroups) * M_LN2); //TODO Is this correct?
    }
    else if (bookkeep.modelPrior == "dependent")
    {
        // determine number of all covariates (covariate groups):
        int nCovs = ucInfo.nUcGroups + fixInfo.nFixGroups + fpInfo.nFps; //TODO Is this correct?

        // determine number of included FPs and which are nonlinear:
        int nInclContinuous = 0;
        PosIntVector nonlinearFps;

        for(PosInt i = 0; i != fpInfo.nFps; i++)
        {
            Powers powersi = mod.fpPars.at(i);
            if (! powersi.empty())
            {
                ++nInclContinuous;

                if(mod.fpPars.at(i) != fpInfo.linearPowers)
                {
                    nonlinearFps.push_back(i);
                }
            }
        }

        // determine number of included discrete covariates:
        int nInclDiscrete = mod.ucPars.size() + fixInfo.nFixGroups;

        // so altogether there are
        int nIncluded = nInclContinuous + nInclDiscrete;
        // included covariates

        // and the number of possible nonlinear transformations
        // for each variable is also included in the computations:
        double sumLogNonlinearPossibilities = 0.0;
        for(PosIntVector::const_iterator
                i = nonlinearFps.begin();
                i != nonlinearFps.end();
                ++i)
        {
            sumLogNonlinearPossibilities += log(fpInfo.numberPossibleFps.at(*i) - 2.0);
            //                              Note: degree 0 and linear degree 1 FP are subtracted
        }

        double result = - log1p(nCovs) - Rf_lchoose(nCovs, nIncluded) -
                log1p(nInclContinuous) - Rf_lchoose(nInclContinuous, nonlinearFps.size()) -
                sumLogNonlinearPossibilities;

        return result;
    }
    else
    {
        return - (ucInfo.nUcGroups * M_LN2);
    }
}

// ***************************************************************************************************//

// 21/11/2012: modify for tbf methodology

// compute (varying part of) marginal likelihood and prior of model and insert it into model set
void
computeGlm(const ModelPar &mod,
           set<Model> &space,
           const DataValues& data,
           const FpInfo& fpInfo,
           const UcInfo& ucInfo,
           const FixInfo& fixInfo,
           Book& bookkeep,
           const GlmModelConfig& config,
           const GaussHermite& gaussHermite)
{
    // log prior
    const double thisLogPrior = getVarLogPrior(mod,
                                               fpInfo,
                                               ucInfo,
                                               fixInfo,
                                               bookkeep);

    // initialize variables which will definitely be overwritten below
    double thisVarLogMargLik = 0.0;

    // this will not be available when this is the null model! then it is *not* overwritten below.
    double zMode = R_NaReal;
    double zVar = R_NaReal;
    double laplaceApprox = R_NaReal;
    double residualDeviance = R_NaReal;
    Cache cache;

    // compute log marginal likelihood, and also as byproducts unnormalized z density information.

    // be careful: if this is the null model, then just input the data computed in R.
    if(mod.size(ucInfo, fixInfo) == 0)
    {
        thisVarLogMargLik = config.nullModelLogMargLik;
    }
    else // not the null model, so at least one other coefficient than the intercept present in the model
    {
        thisVarLogMargLik = getGlmVarLogMargLik(mod, data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite,
                                                cache, zMode, zVar, laplaceApprox, residualDeviance);
    }

    // if we get back NaN
    if (R_IsNaN(thisVarLogMargLik) == TRUE)
    {
        // increment counter of bad models
        bookkeep.nanCounter++;
        // we do not save this here, because for the sampling mode we will have a different function!
    }
    else
    {
        // put all into the modelInfo
        GlmModelInfo info(thisVarLogMargLik, thisLogPrior, cache, zMode, zVar, laplaceApprox, residualDeviance);

        // altogether we have the model:
        Model thisModel(mod, info);

        // and insert it into the model space
        if (space.size() >= bookkeep.nModels)
        {
            set<Model>::iterator it = space.begin();
            if (* it < thisModel)
            { // compare this model to the least probable model in the set
                space.erase(it);
                space.insert(thisModel); // exchange if it is better than this worst model in the set
            }
        }
        else
        {
            space.insert(thisModel);
        }

        // compute log posterior probability (up to an additive constant) and
        // append it to the safe sum object
        bookkeep.modelLogPosteriors.add(thisVarLogMargLik + thisLogPrior);

        // update inclusion probabilities for covariate (groups)
        mod.pushInclusionProbs(fpInfo, ucInfo, bookkeep); //TODO

        // increment distinct models counter
        bookkeep.modelCounter++;
    }

    // display computation progress at each percent:
    if (((bookkeep.modelCounter + bookkeep.nanCounter) %
            std::max(data.totalNumber / 100,
                static_cast<PosLargeInt> (1))
                == 0)
            && bookkeep.verbose) // but only print if verbose option was chosen
    {
        Rprintf("-");
    }
}


// ***************************************************************************************************//


//TODO FINISH THIS FUNCTION

// compute only the models in the list R-list "R_modelConfigs"
List
glmModelsInList(const DataValues& data,
                const FpInfo& fpInfo,
                const UcInfo& ucInfo,
                const FixInfo& fixInfo,
                Book& bookkeep,
                const GlmModelConfig& config,
                const GaussHermite& gaussHermite,
                const List& rcpp_modelConfigs)
{
    // ------------
    // bookkeeping:

    // for computation of inclusion probs:
    // array of IndexSafeSum objects.
//     const int cgwp_length = fpInfo.nFps + ucInfo.nUcGroups;
//     //IndexSafeSum cgwp[fpInfo.nFps + ucInfo.nUcGroups];
//     IndexSafeSum cgwp[cgwp_length];
//     bookkeep.covGroupWisePosteriors = cgwp;

    std::vector<IndexSafeSum> cgwp(fpInfo.nFps + ucInfo.nUcGroups);
    bookkeep.covGroupWisePosteriors = cgwp;
    
    
    
    // start the set of ordered models:
    set<Model> orderedModels;

    // check that the set is large enough for all models in the list
    if (orderedModels.max_size() < static_cast<set<Model>::size_type >(rcpp_modelConfigs.size()))
        Rf_error("\nlist of model space is too large - cannot compute every model\n");

    // ------------
    // process all models in the list:

    for(R_len_t i = 0; i < rcpp_modelConfigs.size(); ++i)
    {
    as<List>(rcpp_modelConfigs[i]);
    
        // this is the current model config:
        ModelPar modelConfig(as<List>(rcpp_modelConfigs[i]),
                             fpInfo);

        // compute this one
        computeGlm(modelConfig, orderedModels,
                   data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);

    }

    // ------------
    // we have finished.

    // now echo statistics:
    if (bookkeep.verbose)
    {
        Rprintf("\nActual number of possible models:  %lu",
                bookkeep.modelCounter);
        Rprintf("\nNumber of non-identifiable models: %lu",
                bookkeep.nanCounter);
        Rprintf("\nNumber of saved possible models:   %zu\n",
                orderedModels.size());
    }

    // ------------
    // allocate the return list
    List ret(orderedModels.size());

    // and fill it:

    // normalize posterior probabilities and correct log prior of the models to return
    // (we do not know here the normalizing constant for the marginal likelihoods!)
    const long double logNormConst = bookkeep.modelLogPosteriors.logSumExp();

    // first the single models
    PosInt i = 0;
    for (set<Model>::const_reverse_iterator
            j = orderedModels.rbegin();
            j != orderedModels.rend();
            j++)
    {
        ret[i++] = j->convert2list(fpInfo,
                                   logNormConst,
                                   bookkeep);
    }

    // then some attributes:

    NumericVector inc(fpInfo.nFps + ucInfo.nUcGroups);
    for (R_len_t i = 0; i != inc.size(); ++i)
    {
        inc[i] = bookkeep.covGroupWisePosteriors[i].sumNormalizedExp(bookkeep.modelLogPosteriors, logNormConst);
    }
    ret.attr("inclusionProbs") = inc;
    ret.attr("numVisited") = static_cast<double>(bookkeep.modelCounter);
    ret.attr("logNormConst") = static_cast<double>(logNormConst);

    // ------------
    // finally return the list.
    return ret;
}


// ***************************************************************************************************//

// recursion via:
void
glmPermPars(PosInt pos, // current position in parameter vector, starting from 0 - copied.
            ModelPar mod, // is copied every time! everything else is call by reference.
            set<Model>& space, // the model space
            const DataValues& data,
            const FpInfo& fpInfo,
            const UcInfo& ucInfo,
            const FixInfo& fixInfo,
            Book& bookkeep,
            const GlmModelConfig& config,
            const GaussHermite& gaussHermite)

{
    // if some fps are still left
    if (pos != fpInfo.nFps)
    {
        // cardinality of the power set at this position
        const PosInt card = fpInfo.fpcards.at(pos);

        // degree 0:
        glmPermPars(pos + 1, mod, space,
                    data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);

        // different degrees for fp at pos:
        // degrees 1, ..., fpmax
        for (PosInt deg = 1; deg <= fpInfo.fpmaxs.at(pos); deg++)
        {
            // increment sums of fp degrees
            mod.fpSize++;

            // partition of deg into card parts
            IntVector part (card);

            // internal variables for comp_next
            bool more1 = false;
            int h(0), t(0);

            do
            {
                // next partition of deg into card parts
                comp_next(deg, card, part, &more1, h, t);

                // convert into multiset
                mod.fpPars.at(pos) = freqvec2Powers(part, card);

                // and go on
                glmPermPars(pos + 1, mod, space,
                            data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);
            }
            while (more1);
        }
    }
    else // no fps left (all FPs have received their powers)
    {
        // no uc group
        computeGlm(mod, space,
                   data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite); //TODO IS THIS THE NULL  MODEL? IF SO ADD NULL+FIXED NEXT

        // different positive number (deg) of uc groups
        for (PosInt deg = 1; deg <= ucInfo.nUcGroups; deg++)
        {
            // partition of deg into card parts
          IntVector subset (deg);

            // internal variables for ksub_next
            bool more2 = false;
            int m(0), m2(0);

            do
            {
                // next subset (positive integers)
                ksub_next(ucInfo.nUcGroups, deg, subset, &more2, m, m2);

                // convert into set
                mod.ucPars = IntSet(subset.data(), subset.data() + deg);

                // and compute this model
                computeGlm(mod, space,
                           data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);
            }
            while (more2);
        }
    }
}

// ***************************************************************************************************//

List
glmSampling(const DataValues& data,
            const FpInfo& fpInfo,
            const UcInfo& ucInfo,
            const FixInfo& fixInfo,
            Book& bookkeep,
            const GlmModelConfig& config,
            const GaussHermite& gaussHermite)
{
    // models which can be found during chain run can be cached in here:
    ModelCache modelCache(bookkeep.nCache);

    // upper limit for num of columns: min(n, maximum fixed + fp + uc columns).
    PosInt maxDim = std::min(static_cast<PosInt>(data.nObs), 1 + fpInfo.maxFpDim + ucInfo.maxUcDim);

    // the FP range
    const PosIntSet fpRange = constructSequence(fpInfo.nFps);

    // start model is the null model!
    ModelMcmc old(fpInfo,
                  ucInfo,
                  maxDim,
                  config.nullModelLogMargLik);

    // insert this model into the cache
    double logPrior = getVarLogPrior(old.modPar,
                                     fpInfo,
                                     ucInfo,
                                     fixInfo,
                                     bookkeep);
    old.logPrior = logPrior;

    // put all into the modelInfo
    GlmModelInfo startInfo(old.logMargLik, logPrior, Cache(), R_NaReal, R_NaReal, R_NaReal, 0.0);

    modelCache.insert(old.modPar, startInfo);

    // start with this model config
    ModelMcmc now(old);

    if(fixInfo.nFixGroups > 0){
      // move to the null model + fixed covariates **********************************************//
      
      // add the fixed covariates to the model configuration
      IntSet s;
      for (unsigned int i = 0; i < fixInfo.nFixGroups; ++i) 
        s.insert(s.end(), i+1);
      now.modPar.fixPars = s;
      
      //get log prior for null+fixed model
     double logPrior2 = getVarLogPrior(now.modPar,
                                fpInfo,
                                ucInfo,
                                fixInfo,
                                bookkeep);
      
      // and marginal log like
      double zMode = 0.0;
      double zVar = 0.0;
      double laplaceApprox = 0.0;
      double residualDeviance = R_NaReal;
      Cache cache;
      
      now.logMargLik = getGlmVarLogMargLik(now.modPar,
                                           data,
                                           fpInfo,
                                           ucInfo,
                                           fixInfo,
                                           bookkeep,
                                           config,
                                           gaussHermite,
                                           cache,
                                           zMode,
                                           zVar,
                                           laplaceApprox,
                                           residualDeviance);
      
      // put all into the modelInfo
      GlmModelInfo start2Info(now.logMargLik, logPrior2, Cache(), R_NaReal, R_NaReal, R_NaReal, 0.0);
      
      modelCache.insert(now.modPar, start2Info);
      
      // start with this model config
      ModelMcmc now2(now);
      
      now = now2;
    }
    
    // Start MCMC sampler***********************************************************//

    GetRNGstate(); // use R's random number generator

    for(PosLargeInt t = 0; t != bookkeep.chainlength; /* ++t explicitly at the end */)
    {
            double logPropRatio; // log proposal ratio

            // randomly select move type
            double u1 = unif_rand();

            if (u1 < old.birthprob)
            {                                                                                        // BIRTH
                    PosInt newCovInd = *discreteUniform<PosIntSet>(old.freeCovs);

                    if (newCovInd <= fpInfo.nFps)
                    {                                                                                // some fp index
                            Int powerIndex = discreteUniform<Int>(0, fpInfo.fpcards[newCovInd-1]);
                            now.modPar.fpPars.at(newCovInd-1).insert(powerIndex);
                            now.modPar.fpSize++; // correct invariants
                            now.dim++;
                            PosInt newPowersEqualPowerIndex = count(now.modPar.fpPars.at(newCovInd-1).begin(), now.modPar.fpPars.at(newCovInd-1).end(), powerIndex);
                            PosInt m = old.modPar.fpPars.at(newCovInd-1).size();

                            logPropRatio = log(double(newPowersEqualPowerIndex)) + log(double(fpInfo.fpcards[newCovInd-1])) - log1p(m);
                    }
                    else
                    {                                                                                // uc index
                            Int index = *discreteUniform(old.freeUcs);
                            now.modPar.ucPars.insert(index);
                            now.dim += ucInfo.ucSizes.at(index - 1);
                            now.freeUcs = now.modPar.getFreeUcs(ucInfo.ucSizes, now.dim, maxDim);

                            logPropRatio = log(double(old.freeUcs.size())) - log(double(now.modPar.ucPars.size()));
                    }

                    now.presentCovs.insert(newCovInd);
                    now.freeCovs = now.modPar.getFreeCovs(fpInfo, now.freeUcs, now.dim, maxDim);

                    if (now.dim == maxDim)
                    {
                            now.birthprob = 0; now.deathprob = now.moveprob = (now.modPar.fpSize > 0) ? 1.0 / 3 : 0.5;
                    } else
                    {
                            now.birthprob = now.deathprob = now.moveprob = (now.modPar.fpSize > 0) ? 0.25 : 1.0 / 3;
                    }

                    logPropRatio += log(now.deathprob) - log(old.birthprob) + log(double(old.freeCovs.size())) - log(double(now.presentCovs.size()));

            }
            else if
            (u1 < old.birthprob + old.deathprob)
            {                                                                                      // DEATH
                    PosInt oldCovInd = *discreteUniform(old.presentCovs);

                    if (oldCovInd <= fpInfo.nFps)
                    {                                                                            // some fp index
                            Powers::iterator powerIterator = discreteUniform(now.modPar.fpPars.at(oldCovInd-1));
                            PosInt oldPowersEqualPowerIndex = count(old.modPar.fpPars.at(oldCovInd-1).begin(), old.modPar.fpPars.at(oldCovInd-1).end(), *powerIterator);
                            now.modPar.fpPars.at(oldCovInd-1).erase(powerIterator);
                            now.modPar.fpSize--; // correct invariants
                            now.dim--;

                            logPropRatio =  - log(double(oldPowersEqualPowerIndex)) - log(double(fpInfo.fpcards[oldCovInd-1])) + log(double(old.modPar.fpPars.at(oldCovInd-1).size()));

                    } else {                                                                                                        // uc index
                            IntSet::iterator IndIterator = discreteUniform(now.modPar.ucPars);
//                            now.modPar.ucSize--;
                            now.dim -= ucInfo.ucSizes.at(*IndIterator - 1);
                            now.modPar.ucPars.erase(IndIterator);
                            now.freeUcs = now.modPar.getFreeUcs(ucInfo.ucSizes, now.dim, maxDim);
                            logPropRatio = log(double(old.modPar.ucPars.size())) - log(double(now.freeUcs.size()));
                    }
                    now.presentCovs = now.modPar.getPresentCovs();
                    now.freeCovs = now.modPar.getFreeCovs(fpInfo, now.freeUcs, now.dim, maxDim);
                    if (now.dim == 1)
                    {
                            now.birthprob = 1; now.deathprob = now.moveprob = 0;
                    } else
                    {
                            now.birthprob = now.deathprob = now.moveprob = (now.modPar.fpSize > 0) ? 0.25 : 1.0 / 3.0;
                    }
                    logPropRatio += log(now.birthprob) - log(old.deathprob) + log(double(old.presentCovs.size())) - log(double(now.freeCovs.size()));

            }
            else if (u1 < old.birthprob + old.deathprob + old.moveprob)
            {                                                                                   // MOVE
                    PosInt CovInd = *discreteUniform<PosIntSet>(old.presentCovs);

                    if (CovInd <= fpInfo.nFps)
                    {                                                                     // some fp index
                            Powers::iterator powerIterator = discreteUniform(now.modPar.fpPars.at(CovInd-1));
                            PosInt oldPowersEqualPowerIndex = count(old.modPar.fpPars.at(CovInd-1).begin(), old.modPar.fpPars.at(CovInd-1).end(), *powerIterator);
                            now.modPar.fpPars.at(CovInd-1).erase(powerIterator);
                            Int powerIndex = discreteUniform<Int>(0, fpInfo.fpcards[CovInd-1]);
                            now.modPar.fpPars.at(CovInd-1).insert(powerIndex);
                            PosInt newPowersEqualPowerIndex = count(now.modPar.fpPars.at(CovInd-1).begin(), now.modPar.fpPars.at(CovInd-1).end(), powerIndex);
                            // free, present Covs and move type probs are unchanged
                            logPropRatio = log(double(newPowersEqualPowerIndex)) - log(double(oldPowersEqualPowerIndex));
                    }
                    else
                    {                                                                                                        // uc index
                            IntSet::iterator IndIterator = discreteUniform(now.modPar.ucPars);
                            now.dim -= ucInfo.ucSizes.at(*IndIterator - 1);
                            now.modPar.ucPars.erase(IndIterator);
                            now.freeUcs = now.modPar.getFreeUcs(ucInfo.ucSizes, now.dim, maxDim);
                            Int index = *discreteUniform<IntSet>(now.freeUcs);
                            now.modPar.ucPars.insert(index);
                            now.dim += ucInfo.ucSizes.at(index - 1);
                            now.freeUcs = now.modPar.getFreeUcs(ucInfo.ucSizes, now.dim, maxDim);
                            // here something may change, therefore:
                            now.freeCovs = now.modPar.getFreeCovs(fpInfo, now.freeUcs, now.dim, maxDim);
                            if (now.dim == maxDim)
                            {
                                    now.birthprob = 0; now.deathprob = now.moveprob = (now.modPar.fpSize > 0) ? 1.0 / 3.0 : 0.5;
                            }
                            else
                            {
                                    now.birthprob = now.deathprob = now.moveprob = (now.modPar.fpSize > 0) ? 0.25 : 1.0 / 3.0;
                            }
                            logPropRatio = 0.0;
                    }
            } else {                                                                                                        // SWITCH (of FP vectors)
                    // select only the FP present covs
                    PosIntSet presentFps = removeElement(old.presentCovs, fpInfo.nFps + 1);

                    // so we have the first power vector:
                    PosInt firstFpInd = *discreteUniform<PosIntSet>(presentFps);
                    Powers first = now.modPar.fpPars.at(firstFpInd - 1);

                    // the second power vector from all other FPs
                    PosIntSet otherFps = removeElement(fpRange, firstFpInd);
                    PosInt secondFpInd = *discreteUniform<PosIntSet>(otherFps);
                    Powers second = now.modPar.fpPars.at(secondFpInd - 1);

                    // save the first
                    Powers saveFirst = first;

                    // copy second to first
                    now.modPar.fpPars.at(firstFpInd - 1) = second;

                    // and save to second
                    now.modPar.fpPars.at(secondFpInd - 1) = saveFirst;

                    // so now we have switched the power vectors.

                    // move type probs are not changed, because the number of present FPs is unchanged,
                    // as well as the dimension of the model.

                    // but carefully update the information which covariates are free and which are present
                    now.freeCovs = now.modPar.getFreeCovs(fpInfo, now.freeUcs, now.dim, maxDim);
                    now.presentCovs = now.modPar.getPresentCovs();

                    // and the proposal ratio is 1, thus the log proposal ratio is 0:
                    logPropRatio = 0;
            }

            // search for log marg lik of proposed model
            GlmModelInfo nowInfo = modelCache.getModelInfo(now.modPar);

            if (R_IsNA(nowInfo.logMargLik))
            { // "now" is a new model

                double zMode = 0.0;
                double zVar = 0.0;
                double laplaceApprox = 0.0;
                double residualDeviance = R_NaReal;
                Cache cache;

                // so we must compute the log marg lik now.
                now.logMargLik = getGlmVarLogMargLik(now.modPar,
                                                 data,
                                                 fpInfo,
                                                 ucInfo,
                                                 fixInfo,
                                                 bookkeep,
                                                 config,
                                                 gaussHermite,
                                                 cache,
                                                 zMode,
                                                 zVar,
                                                 laplaceApprox,
                                                 residualDeviance);

                // check if the new model is OK
                if (R_IsNaN(now.logMargLik))
                {
                    // we do not save this model in the model cache
                    bookkeep.nanCounter++;
                }
                else
                { // OK: then compute the rest, and insert into model cache

                    now.logPrior = getVarLogPrior(now.modPar,
                                              fpInfo,
                                              ucInfo,
                                              fixInfo,
                                              bookkeep);

                    // insert the model parameter/info into the model cache

                    // problem: this could erase the old model from the model cache,
                    // and invalidate the iterator old.mapPos!
                    // ==> so we cannot work with the iterators here.
                    modelCache.insert(now.modPar,
                                  GlmModelInfo(now.logMargLik,
                                               now.logPrior,
                                               cache,
                                               zMode,
                                               zVar,
                                               laplaceApprox,
                                               residualDeviance));
                }
            }
            else // "now" is an old model
            {
                // extract log marg lik and prior from the modelInfo object
                now.logMargLik = nowInfo.logMargLik;
                now.logPrior = nowInfo.logPrior;
            }

            // decide acceptance:
            // for acceptance, the new model must be valid and the acceptance must be sampled
            if ((R_IsNaN(now.logMargLik) == FALSE) &&
                (unif_rand() <= exp(now.logMargLik - old.logMargLik + now.logPrior - old.logPrior + logPropRatio)))
            { // acceptance
                old = now;
            }
            else
            { // rejection
                now = old;
            }

            // so now definitely old == now, and we can
            // increment the associated sampling frequency.
            modelCache.incrementFrequency(now.modPar);

            // echo progress?
            if((++t % std::max(bookkeep.chainlength / 100, static_cast<PosLargeInt>(1)) == 0) &&
                bookkeep.verbose)
            {
                    Rprintf("-"); // display computation progress at each percent
            }
    }

    PutRNGstate(); // no RNs required anymore


    // normalize posterior probabilities and correct log marg lik and log prior
    const long double logNormConst = modelCache.getLogNormConstant();

    // get the nModels best models from the cache as an R list
    List ret = modelCache.getListOfBestModels(fpInfo,
                                              logNormConst,
                                              bookkeep);

    // set the attributes
    ret.attr("numVisited") = modelCache.size();
    ret.attr("inclusionProbs") = modelCache.getInclusionProbs(logNormConst, fpInfo.nFps, ucInfo.nUcGroups);
    ret.attr("logNormConst") = logNormConst;

    if (bookkeep.verbose){
        Rprintf("\nNumber of non-identifiable model proposals:     %lu", bookkeep.nanCounter);
        Rprintf("\nNumber of total cached models:                  %d", modelCache.size());
        Rprintf("\nNumber of returned models:                      %d\n", Rf_length(ret));
    }

    // and return
    return ret;
}


// ***************************************************************************************************//


List
glmExhaustive(const DataValues& data,
              const FpInfo& fpInfo,
              const UcInfo& ucInfo,
              const FixInfo& fixInfo,
              Book& bookkeep,
              const GlmModelConfig& config,
              const GaussHermite& gaussHermite)
{
    // no map needed for exhaustive search, a set is the right thing:
    set<Model> orderedModels;

    // check that the set is large enough for all models
    if (orderedModels.max_size() < data.totalNumber)
        Rf_error("\nmodel space is too large - cannot compute every model\n");

    // start model
    ModelPar startModel(fpInfo.nFps);

    // bookkeeping

    // for computation of inclusion probs:
    // array of IndexSafeSum objects.
    //const int cgwp_length = fpInfo.nFps + ucInfo.nUcGroups;
    
    //IndexSafeSum cgwp[cgwp_length];
    //IndexSafeSum cgwp[fpInfo.nFps + ucInfo.nUcGroups];
    //bookkeep.covGroupWisePosteriors = cgwp;

    // now with vectors instead of arrays
    std::vector<IndexSafeSum> cgwp(fpInfo.nFps + ucInfo.nUcGroups);
    bookkeep.covGroupWisePosteriors = cgwp;
    
    
    // calculate the true null model if we have any fixed covariates,
    // otherwise it comes later
    if(fixInfo.nFixGroups != 0)
      computeGlm(startModel, orderedModels,
               data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);
    
    // add the fixed covariates to the model configuration
    IntSet s;
    for (unsigned int i = 0; i < fixInfo.nFixGroups; ++i) 
      s.insert(s.end(), i+1);
    startModel.fixPars = s;
      
    
    // start computation
    glmPermPars(0, startModel, orderedModels,
                data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);

    // we have finished.

    // now echo statistics:
    if (bookkeep.verbose)
    {
        Rprintf("\nActual number of possible models:  %lu",
                bookkeep.modelCounter);
        Rprintf("\nNumber of non-identifiable models: %lu",
                bookkeep.nanCounter);
        Rprintf("\nNumber of saved possible models:   %zu\n",
                orderedModels.size());
    }

    // normalize posterior probabilities of the models to return
    // (we do not know here the normalizing constant for the marginal likelihoods!)
    const long double logNormConst = bookkeep.modelLogPosteriors.logSumExp();

    // allocate the return list
    List ret(orderedModels.size());

    // and fill it:

    // first the single models
    R_len_t i = 0;
    for (set<Model>::const_reverse_iterator
            j = orderedModels.rbegin();
            j != orderedModels.rend();
            j++)
    {
        ret[i++] = j->convert2list(fpInfo,
                                   logNormConst,
                                   bookkeep);
    }

    // then some attributes:

    NumericVector inc(fpInfo.nFps + ucInfo.nUcGroups); // TODO should I add fix here
    for (R_len_t i = 0; i != inc.size(); ++i)
    {
        inc[i] = bookkeep.covGroupWisePosteriors[i].sumNormalizedExp(bookkeep.modelLogPosteriors, logNormConst);
    }
    ret.attr("inclusionProbs") = inc;
    ret.attr("numVisited") = static_cast<double>(bookkeep.modelCounter);
    ret.attr("logNormConst") = static_cast<double>(logNormConst);

    // finally return the list.
    return ret;
}

// ***************************************************************************************************//

// 21/11/2012: add tbf option
// 03/12/2012: add Cox regression with tbfs
// 03/07/2013: remove nullModelInfo and only get nullModelLogMargLik

// R call is:
//
//Ret <-
//    .External (cpp_glmBayesMfp,
//               data,
//               fpInfos,
//               ucInfos,
//               fixInfos,
//               searchConfig,
//               distribution,
//               options)
// [[Rcpp::export]]
SEXP
cpp_glmBayesMfp(List rcpp_data, List rcpp_fpInfos, List rcpp_ucInfos, List rcpp_fixInfos,
                List rcpp_searchConfig, List rcpp_distribution, List rcpp_options )
{
    // ----------------------------------------------------------------------------------
    // extract arguments
    // ----------------------------------------------------------------------------------

//     r_interface = CDR(r_interface);
//     List rcpp_data(CAR(r_interface));
// 
//     r_interface = CDR(r_interface);
//     List rcpp_fpInfos(CAR(r_interface));
// 
//     r_interface = CDR(r_interface);
//     List rcpp_ucInfos(CAR(r_interface));
// 
// 	  r_interface = CDR(r_interface);
// 	  List rcpp_fixInfos(CAR(r_interface));
// 
//     r_interface = CDR(r_interface);
//     List rcpp_searchConfig(CAR(r_interface));
// 
//     r_interface = CDR(r_interface);
//     List rcpp_distribution(CAR(r_interface));
// 
//     r_interface = CDR(r_interface);
//     List rcpp_options(CAR(r_interface));


    // ----------------------------------------------------------------------------------
    // unpack the R objects
    // ----------------------------------------------------------------------------------

    // data:
    const NumericMatrix n_x = rcpp_data["x"];
    const AMatrix x(n_x.begin(), n_x.nrow(),
                   n_x.ncol());

    const NumericMatrix n_xCentered = rcpp_data["xCentered"];
    const AMatrix xCentered(n_xCentered.begin(), n_xCentered.nrow(),
                           n_xCentered.ncol());

    const NumericVector n_y = rcpp_data["y"];
    const AVector y(n_y.begin(), n_y.size());

    const IntVector censInd = as<IntVector>(rcpp_data["censInd"]);

    // FP configuration:

    // vector of maximum fp degrees
    const PosIntVector fpmaxs = as<PosIntVector>(rcpp_fpInfos["fpmaxs"]);
    // corresponding vector of fp column indices
    const PosIntVector fppos = rcpp_fpInfos["fppos"];
    // corresponding vector of power set cardinalities
    const PosIntVector fpcards = rcpp_fpInfos["fpcards"];
    // names of fp terms
    const StrVector fpnames = rcpp_fpInfos["fpnames"];


    // UC configuration:

    const PosIntVector ucIndices = rcpp_ucInfos["ucIndices"];
    List rcpp_ucColList = rcpp_ucInfos["ucColList"];

    std::vector<PosIntVector> ucColList;
    for (R_len_t i = 0; i != rcpp_ucColList.length(); ++i)
    {
        ucColList.push_back(as<PosIntVector>(rcpp_ucColList[i]));
    }


	// Fixed Covariate configuration:

	const PosIntVector fixIndices = rcpp_fixInfos["fixIndices"];
	List rcpp_fixColList = rcpp_fixInfos["fixColList"];

	std::vector<PosIntVector> fixColList;
	for (R_len_t i = 0; i != rcpp_fixColList.length(); ++i)
	{
		fixColList.push_back(as<PosIntVector>(rcpp_fixColList[i]));
	}


    
    // model search configuration:

    const double totalNumber = as<double>(rcpp_searchConfig["totalNumber"]);
    const PosInt nModels = as<PosInt>(rcpp_searchConfig["nModels"]);
    const bool empiricalBayes = as<bool>(rcpp_searchConfig["empiricalBayes"]);
    const bool useFixedg = as<bool>(rcpp_searchConfig["useFixedg"]);
    const bool doSampling = as<bool>(rcpp_searchConfig["doSampling"]);
    const double chainlength = as<double>(rcpp_searchConfig["chainlength"]);
    const PosInt nCache = as<PosInt>(rcpp_searchConfig["nCache"]);
    const double largeVariance = as<double>(rcpp_searchConfig["largeVariance"]);
    const bool useBfgs = as<bool>(rcpp_searchConfig["useBfgs"]);
    const bool useFixedc = as<bool>(rcpp_searchConfig["useFixedc"]);

    // there might be a single model configuration saved in the searchConfig:
    bool onlyComputeModelsInList;
    try {
        onlyComputeModelsInList = true;
        List rcpp_modelConfigs = rcpp_searchConfig["modelConfigs"];
    } catch (std::exception& e) {
        onlyComputeModelsInList = false;
    }
    // we need to try-catch it because there might be no element "modelConfigs" in
    // rcpp_searchConfig in which case Rcpp throws an exception.

    // distributions info:

    const std::string modelPrior = as<std::string>(rcpp_distribution["modelPrior"]);
    const bool doGlm = as<bool>(rcpp_distribution["doGlm"]);
    const bool tbf = as<bool>(rcpp_distribution["tbf"]);
    const double nullModelLogMargLik = as<double>(rcpp_distribution["nullModelLogMargLik"]);
    const double nullModelDeviance = as<double>(rcpp_distribution["nullModelDeviance"]);
    const double fixedg = as<double>(rcpp_distribution["fixedg"]);
    const double empiricalMean = as<double>(rcpp_distribution["yMean"]);
    const bool empiricalgPrior = as<bool>(rcpp_distribution["empiricalgPrior"]);
    
    S4 rcpp_gPrior = rcpp_distribution["gPrior"];
    List rcpp_family = rcpp_distribution["family"];

    // other options:

    const bool verbose = as<bool>(rcpp_options["verbose"]);
    const bool debug = as<bool>(rcpp_options["debug"]);
#ifdef _OPENMP
    const bool useOpenMP = as<bool>(rcpp_options["useOpenMP"]);
#endif
    const GaussHermite gaussHermite(as<List>(rcpp_options["gaussHermite"]));
    const bool higherOrderCorrection = as<bool>(rcpp_options["higherOrderCorrection"]);


    // ----------------------------------------------------------------------------------
    // further process input information
    // ----------------------------------------------------------------------------------

    // data:

    // only the intercept is always included, that is fixed, in the model
    IntSet fixedCols;
    fixedCols.insert(1); //vestigial code that isn't part of the new support for fixed vars

    const DataValues data(x, xCentered, y, censInd, totalNumber, fixedCols);

    // FP configuration:
    const FpInfo fpInfo(fpcards, fppos, fpmaxs, fpnames, x);

    // UC configuration:

    // determine sizes of the UC groups, and the total size == maximum size reached together by all
    // UC groups.
    PosIntVector ucSizes;
    PosInt maxUcDim = 0;
    for (vector<PosIntVector>::const_iterator cols = ucColList.begin(); cols != ucColList.end(); ++cols)
    {
        PosInt thisSize = cols->size();

        maxUcDim += thisSize;
        ucSizes.push_back(thisSize);
    }
    const UcInfo ucInfo(ucSizes, maxUcDim, ucIndices, ucColList);


	// Fix configuration:

	// determine sizes of the fixed covariate groups, and the total size == maximum size reached together by all
	// fix groups.
	PosIntVector fixSizes;
	PosInt maxFixDim = 0;
	for (vector<PosIntVector>::const_iterator cols = fixColList.begin(); cols != fixColList.end(); ++cols)
	{
		PosInt thisSize = cols->size();

		maxFixDim += thisSize;
		fixSizes.push_back(thisSize);
	}
	const FixInfo fixInfo(fixSizes, maxFixDim, fixIndices, fixColList);




    // model search configuration:
    Book bookkeep(tbf,
                  doGlm,
                  empiricalBayes,
                  useFixedg,
                  useFixedc,
                  chainlength,
                  doSampling,
                  verbose,
                  modelPrior,
                  nModels,
                  nCache,
                  largeVariance,
                  useBfgs,
                  debug,
                  higherOrderCorrection);

    // model configuration:
    const GlmModelConfig config(rcpp_family, nullModelLogMargLik, nullModelDeviance, fixedg, rcpp_gPrior,
                                data.response, bookkeep.debug, bookkeep.useFixedc, empiricalMean,
                                empiricalgPrior);

    // use only one thread if we do not want to use openMP.
#ifdef _OPENMP
    if(! useOpenMP)
    {
        omp_set_num_threads(1);
    } else {
        // else use all available cpu's.
        omp_set_num_threads(omp_get_num_procs());
    }
#endif

    // ----------------------------------------------------------------------------------
    // now either compute only one Model, do model sampling or do an exhaustive search
    // ----------------------------------------------------------------------------------

    if(onlyComputeModelsInList)
    {
        return glmModelsInList(data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite, as<List>(rcpp_searchConfig["modelConfigs"]));
    }
    else if(doSampling)
    {
        return glmSampling(data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);
    }
    else
    {
        return glmExhaustive(data, fpInfo, ucInfo, fixInfo, bookkeep, config, gaussHermite);
    }
}

// ***************************************************************************************************//

// End of file.

/*
 * optimize.h
 *
 *  Created on: 08.12.2009
 *      Author: daniel
 */

#ifndef OPTIMIZE_H_
#define OPTIMIZE_H_

#include "types.h"

// modified from R's scalar function "optimize" routine "Brent_fmin"
// in /src/appl/fmin.c,
// in order to take a functor instead of an ordinary function, and does not
// take an info argument

// original documentation:

//    returns an approximation  x  to the point where  f  attains a minimum  on
//    the interval  (ax,bx)  is determined.
//
//    INPUT..
//
//    ax    left endpoint of initial interval
//    bx    right endpoint of initial interval
//    f     function which evaluates  f(x, info)  for any  x
//          in the interval  (ax,bx)
//    tol   desired length of the interval of uncertainty of the final
//          result ( >= 0.)
//
//    OUTPUT..
//
//    fmin  abcissa approximating the point where  f  attains a minimum
//
//        The method used is a combination of  golden  section  search  and
//    successive parabolic interpolation.  convergence is never much slower
//    than  that  for  a  Fibonacci search.  If  f  has a continuous second
//    derivative which is positive at the minimum (which is not  at  ax  or
//    bx),  then  convergence  is  superlinear, and usually of the order of
//    about  1.324....
//        The function  f  is never evaluated at two points closer together
//    than  eps*abs(fmin)+(tol/3), where eps is  approximately  the  square
//    root  of  the  relative  machine  precision.   if   f   is a unimodal
//    function and the computed values of   f   are  always  unimodal  when
//    separated  by  at least  eps*abs(x)+(tol/3), then  fmin  approximates
//    the abcissa of the global minimum of  f  on the interval  ax,bx  with
//    an error less than  3*eps*abs(fmin)+tol.  if   f   is  not  unimodal,
//    then fmin may approximate a local, but perhaps non-global, minimum to
//    the same accuracy.
//        This function subprogram is a slightly modified  version  of  the
//    Algol  60 procedure  localmin  given in Richard Brent, Algorithms for
//    Minimization without Derivatives, Prentice-Hall, Inc. (1973).


template <class Fun>
class Brent {
public:
    // setup the object
    // - function is the function to be maximized in the interval (lowerBound, upperBound)
    // - lowerBound: lower bound on the function argument
    // - upperBound: upper bound on the function argument
    // - precision: desired length of the interval of uncertainty of the final result ( > 0.0,
    //              default: fourth root of machine precision)
    Brent(Fun& function,
          double lowerBound,
          double upperBound,
          double precision=sqrt(EPS)) : // EPS is the square root of the machine precision
              function(function), lowerBound(lowerBound),
                    upperBound(upperBound), precision(precision)
        {
            // check arguments
            if (R_finite(lowerBound) == FALSE || R_finite(upperBound) == FALSE)
                Rf_error("Brent: bounds must be finite");

            if (lowerBound >= upperBound)
                Rf_error("Brent: lowerBound not smaller than upperBound");

            if (precision <= 0.0)
                Rf_error("Brent: precision not positive");
        }

    // minimize the function
    double
    minimize ();

private:
    // the function we want to maximize
    Fun& function;

    // constraints on the function argument
    const double lowerBound;
    const double upperBound;

    // settings
    const double precision;
};

// the actual minimization function
template<class Fun>
    double
    Brent<Fun>::minimize()
    {
        /*  c is the squared inverse of the golden ratio */
        const double c = (3.0 - sqrt(5.0)) * 0.5;

        /* Local variables */
        double a, b, d, e, p, q, r, u, v, w, x;
        double t2, fu, fv, fw, fx, xm, eps, tol1, tol3;

        /*  eps is approximately the square root of the relative machine precision. */
        eps = DBL_EPSILON;
        tol1 = eps + 1.0; /* the smallest 1.000... > 1 */
        eps = sqrt(eps);

        a = lowerBound;
        b = upperBound;

        v = a + c * (b - a);
        w = v;
        x = v;

        d = 0.0; /* -Wall */
        e = 0.0;
        fx = function(x);
        fv = fx;
        fw = fx;
        tol3 = precision / 3.0;

        /*  main loop starts here ----------------------------------- */

        for (;;)
        {
            xm = (a + b) * 0.5;
            tol1 = eps * fabs(x) + tol3;
            t2 = tol1 * 2.0;

            /* check stopping criterion */

            if (fabs(x - xm) <= t2 - (b - a) * 0.5)
                break;
            p = 0.0;
            q = 0.0;
            r = 0.0;
            if (fabs(e) > tol1)
            { /* fit parabola */

                r = (x - w) * (fx - fv);
                q = (x - v) * (fx - fw);
                p = (x - v) * q - (x - w) * r;
                q = (q - r) * 2.0;
                if (q > 0.0)
                    p = - p;
                else
                    q = - q;
                r = e;
                e = d;
            }

            if (fabs(p) >= fabs(q * 0.5 * r) || p <= q * (a - x) || p >= q * (b - x))
            { /* a golden-section step */

                if (x < xm)
                    e = b - x;
                else
                    e = a - x;
                d = c * e;
            }
            else
            { /* a parabolic-interpolation step */

                d = p / q;
                u = x + d;

                /* f must not be evaluated too close to ax or bx */

                if (u - a < t2 || b - u < t2)
                {
                    d = tol1;
                    if (x >= xm)
                        d = - d;
                }
            }

            /* f must not be evaluated too close to x */

            if (fabs(d) >= tol1)
                u = x + d;
            else if (d > 0.)
                u = x + tol1;
            else
                u = x - tol1;

            fu = function(u);

            /*  update  a, b, v, w, and x */

            if (fu <= fx)
            {
                if (u < x)
                    b = x;
                else
                    a = x;
                v = w;
                w = x;
                x = u;
                fv = fw;
                fw = fx;
                fx = fu;
            }
            else
            {
                if (u < x)
                    a = u;
                else
                    b = u;
                if (fu <= fw || w == x)
                {
                    v = w;
                    fv = fw;
                    w = u;
                    fw = fu;
                }
                else if (fu <= fv || v == x || v == w)
                {
                    v = u;
                    fv = fu;
                }
            }
        }
        /* end of main loop */

        // return the found minimum
        return x;
    }



#endif /* OPTIMIZE_H_ */

/*
 * gpriors.cpp
 *
 *  Created on: 22.11.2012
 *      Author: daniel
 */


#include "gpriors.h"


// compute M(a, b)
static double
incInvGammaLogNormConst(double a, double b)
{
    double logNormConst;
    if(b > 0)
    {
        logNormConst = a * log(b) - Rf_pgamma(b, a, 1.0, 1, 1) - Rf_lgammafn(a);
    } else {
        logNormConst = log(a);
    }
    return logNormConst;
}

// Log prior density
double
IncInvGammaGPrior::logDens(double g) const
{
    return (- (a + 1.0) * log1p(g) - b / (g + 1.0) + incInvGammaLogNormConst(a, b));
}


// for this class we have a closed form for the log marginal likelihood
// resulting from the TBF approach
double
IncInvGammaGPrior::getTBFLogMargLik(double residualDeviance, int df) const
{
    return (incInvGammaLogNormConst(a, b) -
            incInvGammaLogNormConst(a + df / 2.0, b + residualDeviance / 2.0) +
            residualDeviance / 2.0);
}

#include <R.h>
#include <Rinternals.h>
#include <stdlib.h> // for NULL
#include <R_ext/Rdynload.h>

/* FIXME: 
   Check these declarations against the C/Fortran source code.
*/

/* .Call calls */
extern SEXP _glmBfp_cpp_bfgs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
extern SEXP _glmBfp_cpp_coxfit(SEXP, SEXP, SEXP, SEXP, SEXP);
extern SEXP _glmBfp_cpp_evalZdensity(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
extern SEXP _glmBfp_cpp_glmBayesMfp(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
extern SEXP _glmBfp_cpp_optimize(SEXP, SEXP, SEXP, SEXP);
extern SEXP _glmBfp_cpp_sampleGlm(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
extern SEXP _glmBfp_predBMAcpp(SEXP, SEXP, SEXP);

static const R_CallMethodDef CallEntries[] = {
    {"_glmBfp_cpp_bfgs",         (DL_FUNC) &_glmBfp_cpp_bfgs,         6},
    {"_glmBfp_cpp_coxfit",       (DL_FUNC) &_glmBfp_cpp_coxfit,       5},
    {"_glmBfp_cpp_evalZdensity", (DL_FUNC) &_glmBfp_cpp_evalZdensity, 7},
    {"_glmBfp_cpp_glmBayesMfp",  (DL_FUNC) &_glmBfp_cpp_glmBayesMfp,  7},
    {"_glmBfp_cpp_optimize",     (DL_FUNC) &_glmBfp_cpp_optimize,     4},
    {"_glmBfp_cpp_sampleGlm",    (DL_FUNC) &_glmBfp_cpp_sampleGlm,    9},
    {"_glmBfp_predBMAcpp",       (DL_FUNC) &_glmBfp_predBMAcpp,       3},
    {NULL, NULL, 0}
};

void R_init_glmBfp(DllInfo *dll)
{
    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
    R_useDynamicSymbols(dll, FALSE);
}

// *      13/07/2015 Replace assert() with Rccp:Stop()


#include "iwls.h"
#include "types.h"
#include "rcppExport.h"
//#include <cassert>
#include "design.h"
#include <stdexcept>
#include <sstream>
#include "linalgInterface.h"

// criterion for comparison of two Column vectors of the same size
// max_j (abs(a_j - b_j) / abs(b_j) + 0.01)
// this is similar to the criterion used by R's glm routine on the deviance scale.
// However, we want to avoid the posterior scale because it would slow down the algorithm...
// (computing this criterion is easier than computing the likelihood * prior)
double
criterion(const AVector& a, const AVector& b)
{
    // check lengths
    //assert(a.n_elem == b.n_elem);
    if(a.n_elem != b.n_elem) Rcpp::stop("iwls.cpp:criterion: a.n_elem != b.n_elem");
    
    // this will be the returned value
    double ret = 0.0;

    // now iterate over the elements
#pragma omp parallel for
    for (PosInt j = 0; j < a.n_elem; ++j)
    {
        double tmp = fabs(a(j) - b(j)) / (fabs(b(j)) + 0.01);

        // note that the "critical" directive is vital here!!
        // Otherwise two executions of the same code can lead to different answers.
#pragma omp critical
        ret = (tmp > ret) ? tmp : ret; /* fmax(ret, tmp); */
    }

    // return the criterion value.
    return ret;
}


// constructor: constructs the Iwls object for given model and data.
Iwls::Iwls(const ModelPar &mod,
           const DataValues& data,
           const FpInfo& fpInfo,
           const UcInfo& ucInfo,
           const FixInfo& fixInfo,
           const GlmModelConfig& config,
           const AVector& linPredStart,
           bool conditional,
           double epsilon,
           bool debug,
           bool tbf) :
           design(getDesignMatrix(mod, data, fpInfo, ucInfo, fixInfo)),
           nCoefs(design.n_cols),
           isNullModel(nCoefs == 1),
           useFixedZ(conditional),
           nObs(design.n_rows),
           // not possible because this could be the null model: designWithoutIntercept(nObs, nCoefs - 1),
           response(data.response),
           config(config),
           invSqrtDispersions(1.0 / arma::sqrt(config.dispersions)),
           unscaledPriorPrec(nCoefs, nCoefs),
           results(linPredStart, nCoefs),
           epsilon(epsilon),
           // verbose(debug),
           tbf(tbf)
{
    // only do additional computations if not the TBF methodology is used
    if(! tbf)
    {
        if(! isNullModel)
        {
          AMatrix scaledDesignWithoutInterceptCrossprod;
          
           if(!config.empiricalgPrior){
            // Scaled design matrix without the intercept.
            // This will be diag(dispersions)^(-1/2) * design[, -1]
            // (attention with 0-based indexing of Armadillo objects!)
            AMatrix scaledDesignWithoutIntercept = arma::diagmat(invSqrtDispersions) * design.cols(1, nCoefs - 1);

            // then the log of the determinant of B'(dispersions)^(-1)B, which is part of the submatrix of R^-1
            // (we know that B'(dispersions)^(-1)B is positive definite, so we do not need to check the sign of the determinant)
            scaledDesignWithoutInterceptCrossprod = arma::trans(scaledDesignWithoutIntercept) * scaledDesignWithoutIntercept;
           }
           
            AMatrix infoMatrix;
            if(config.empiricalgPrior)
            {
              IwlsResults resultsFisher = results;
              
              unscaledPriorPrec.zeros();
              infoMatrix = getInformation(100,
                                          nObs,
                                          invSqrtDispersions,
                                          resultsFisher,
                                          config,
                                          response,
                                          design,
                                          epsilon,
                                          unscaledPriorPrec
              ); //an alternative to using the X'X covariance matrix
              
              scaledDesignWithoutInterceptCrossprod = infoMatrix.submat(1, 1, nCoefs - 1, nCoefs - 1);
              
            }
            
            // input that (the main ingredient) into the unscaled R^-1
            // but first be sure there are zeroes anywhere else:
            unscaledPriorPrec.zeros();
            
            unscaledPriorPrec.submat(1, 1, nCoefs - 1, nCoefs - 1) = scaledDesignWithoutInterceptCrossprod / config.cfactor;

           //  Rcpp::Rcout << "Prior Prec:\n"<< unscaledPriorPrec << std::endl;
            
           // if(config.empiricalgPrior) unscaledPriorPrec.submat(1, 1, nCoefs - 1, nCoefs - 1) = infoMatrix.submat(1, 1, nCoefs - 1, nCoefs - 1);
            

            // now directly use the cholesky routine to avoid copying too much unnecessarily
            int info = potrf(false,
                             scaledDesignWithoutInterceptCrossprod);

            // check that all went well
            if(info != 0)
            {
                std::ostringstream stream;
                stream << "dpotrf(scaledDesignWithoutInterceptCrossprod) got error code " << info << "in Iwls constructor";
                throw std::domain_error(stream.str().c_str());
            }
            // now scaledDesignWithoutInterceptCrossprod contains the cholesky factor!

            // also do not copy the cholesky factor saved now in nonInterceptDesignCrossprod into an extra matrix,
            // but use the Triangular view
            logScaledDesignWithoutInterceptCrossprodDeterminant =
                    2.0 * arma::as_scalar(arma::sum(arma::log(arma::diagvec(scaledDesignWithoutInterceptCrossprod))));
        } else {
            // this is the null model

            // be sure that this is correct:
            unscaledPriorPrec(0, 0) = 0.0;
        }
    }
}

// 03/07/2013: add offsets

// do the Iwls algorithm for a given covariance factor g and start linear predictor linPred,
// until convergence or until the maximum number of iterations is reached.
// so also only one iwls step can be performed with this function.
// Note that the linear predictor is the sum of X^T * beta and the vector of offsets.
// returns the number of iterations.
PosInt
Iwls::startWithLastLinPred(PosInt maxIter,
                              double g)
{
    // initialize iteration counter and stopping criterion
    PosInt iter = 0;
    bool converged = false;

    // do IWLS for at most 30 iterations and unfulfilled stopping criterion
    while ((iter++ < maxIter) && (! converged))
    {
        // compute the pseudo-observations and corresponding sqrt(weights) from the linear predictor
        AVector pseudoObs(nObs);
        AVector sqrtWeights(invSqrtDispersions);

#pragma omp parallel for
        for(PosInt i = 0; i < nObs; ++i)
        {
            double mu = config.link->linkinv(results.linPred(i));
            double dmudEta = config.link->mu_eta(results.linPred(i));

            pseudoObs(i) = results.linPred(i) - config.offsets(i) + (response(i) - mu) / dmudEta;
            sqrtWeights(i) *= dmudEta / sqrt(config.distribution->variance(mu));
        }

        // calculate X'sqrt(W), which is needed twice
        AMatrix XtsqrtW = arma::trans(design) * arma::diagmat(sqrtWeights);

        // calculate the precision matrix Q by doing a rank update:
        // if full Bayes is used, then:
        // Q = tcrossprod(X'sqrt(W)) + 1/g * unscaledPriorPrec
        // if TBF are used, then:
        // Q = tcrossprod(X'sqrt(W))
        double scaleFactor = tbf ? 0.0 : 1.0 / g;
        results.qFactor = unscaledPriorPrec;
        syrk(false,
             false,
             XtsqrtW,
             scaleFactor,
             results.qFactor);

        // decompose into Cholesky factor, Q = LL':
        int info = potrf(false,
                         results.qFactor);

        // check that no error occured
        if(info != 0)
        {
            std::ostringstream stream;
            stream << "Cholesky factorization Q = LL' got error code " << info <<
                    " in IWLS iteration " << iter;
            if(! tbf)
            {
                stream << " for z=" << ::log(g);
            }
            throw std::domain_error(stream.str().c_str());
        }

        // save the old coefficients vector
        AVector coefs_old = results.coefs;

        // the rhs of the equation Q * m = rhs   or    R'R * m = rhs
        pseudoObs = arma::diagmat(sqrtWeights) * pseudoObs;
        results.coefs = XtsqrtW * pseudoObs;
        // note that we have some steps to go until the computation
        // of results.coefs is finished!

        // forward-backward solve LL' * v = rhs
        info = potrs(false,
                     results.qFactor,
                     results.coefs);

        // check that no error occured
        if(info != 0)
        {
            std::ostringstream stream;
            stream << "Forward-backward solve got error code " << info <<
                    " in IWLS iteration " << iter;
            if(! tbf)
            {
                stream << " for z=" << ::log(g);
            }
            throw std::domain_error(stream.str().c_str());
        }

        // the new linear predictor is
        results.linPred = design * results.coefs + config.offsets;

        // compare on the coefficients scale, but not in the first iteration where
        // it is not clear from where coefs_old came. Be safe and always
        // decide for non-convergence in this case.
        converged = (iter > 1) ? (criterion(coefs_old, results.coefs) < epsilon) : false;
    }

    // do not (!)
    // warn if IWLS did not converge within the maximum number of iterations
    // because the maximum number of iterations can be set by user of this function.

    // compute log precision determinant
    results.logPrecisionDeterminant = 2.0 * arma::as_scalar(arma::sum(arma::log(arma::diagvec(results.qFactor))));

    // last but not least return the number of iterations
    return iter;
}

// do the Iwls algorithm for a given covariance factor g and new start linear predictor
// linPredStart.
PosInt
Iwls::startWithNewLinPred(PosInt maxIter,
                          double g,
                          const AVector& linPredStart)
{
    // copy start value into linear predictor of the iwls object
    results.linPred = linPredStart;

    // then run the iwls algorithm
    return startWithLastLinPred(maxIter, g);
}

// 03/07/2013: add offsets

// do the Iwls algorithm for a given covariance factor g and new start coefficients vector
// coefsStart.
PosInt
Iwls::startWithNewCoefs(PosInt maxIter,
                  double g,
                  const AVector& coefsStart)
{
    // start with new linpred deriving from the coefs
    return startWithNewLinPred(maxIter, g, design * coefsStart + config.offsets);
}

// 03/07/2013: add offsets

// compute the log of the (unnormalized)
// posterior density for a given parameter consisting of the coefficients vector and z.
//
// Note that it is important to incorporate all model-depending constants here,
// because this function is also used in the Chib-Jeliazkov marginal likelihood estimation,
// comparing different models!!
//
// useFixedZ: is the log-covariance factor z fixed? Then the conditional posterior
// density of the coefficients vector is returned (so the prior of z is not included).
double
Iwls::computeLogUnPosteriorDens(const Parameter& sample) const
{
    // compute the sample of the linear predictor:
    AVector linPredSample = design * sample.coefs + config.offsets;

    // compute the resulting mean vector from the linear predictor via the response function
    AVector meansSample(linPredSample.n_elem);

#pragma omp parallel for
    for(PosInt i = 0; i < meansSample.n_elem; ++i)
    {
        meansSample(i) = config.link->linkinv(linPredSample(i));
    }

    // start with the log likelihood of this coefficients, it is always included
    // this part is included in both cases because it does not depend on
    // the prior on the (non-intercept) effects:

    double ret = config.distribution->loglik(meansSample.memptr());

    // now it depends again on null model or not.

    if(! isNullModel)
    {
        // map z sample on the original g scale
        double g = exp(sample.z);

        // calculate ||(dispersions)^(-1/2) * B * beta||^2
        AVector scaledBcoefsSample = arma::diagmat(invSqrtDispersions) * (linPredSample - sample.coefs(0));

        // this avoids this multiplication of general matrices:
        // "DEVector scaledBcoefsSample = scaledDesignWithoutIntercept * sample.coefs(_(2, nCoefs));"
        double scaledBcoefsSampleNormSquared = arma::dot(scaledBcoefsSample, scaledBcoefsSample);

        // now add the non-null model specific part, which comes from the prior on
        // the coefficients
        ret += 0.5 * (logScaledDesignWithoutInterceptCrossprodDeterminant -
                      scaledBcoefsSampleNormSquared / (g * config.cfactor) -
                     (nCoefs - 1.0) * (2.0 * M_LN_SQRT_2PI + sample.z + log(config.cfactor)));

        if(! useFixedZ)
        {
            // and the log prior of this g
            double logGPrior = config.gPrior->logDens(g);

            // add the log prior of z
            ret += logGPrior + sample.z;

            // note that the sample.z has its origin in the density transformation from g to z.
            // if the prior on g was discrete and not continuous, this part would not be included in general.
        }
    }

    // return the correct value
    return ret;
}

// compute the deviance of the current model, which in R is done by the glm.fit function
// This is required to compute the TBF.
// Note that this changes the Iwls object, because it iterates until convergence
// or until the maximum number of iterations has been reached.
double
Iwls::computeDeviance(PosInt maxIter)
{
    PosInt iter = startWithLastLinPred(maxIter, R_PosInf);

    // if IWLS did not converge within the maximum number of iterations,
    // throw error which is then caught by getGlmVarLogMargLik later on
    if(iter > maxIter)
    {
        std::ostringstream stream;
        stream << "model could not be fitted within " << maxIter <<
                " IWLS iterations. This could be a result of separability in logistic regression, e.g.";
        throw std::domain_error(stream.str().c_str());
    }

    // compute the resulting mean vector from the linear predictor via the response function
    AVector means(nObs);

#pragma omp parallel for
    for(PosInt i = 0; i < nObs; ++i)
    {
        means(i) = config.link->linkinv(results.linPred(i));
    }

    // compute the log-likelihood
    double logLik = config.distribution->loglik(means.memptr());

    // return the deviance, which is just the scaled log-likelihood
    double ret = - 2.0 * logLik;
    return ret;
}


// Compute a standard GLM to get the observed Fisher Information to use as covariance matrix.
AMatrix 
Iwls::getInformation(PosInt maxIter, PosInt nObs, AVector invSqrtDispersions, IwlsResults results,
          const GlmModelConfig& config, const AVector& response, const AMatrix design,
          double epsilon, AMatrix unscaledPriorPrec)
{
  
  // initialize iteration counter and stopping criterion
  PosInt iter = 0;
  bool converged = false;
  
  AVector finalWeights(invSqrtDispersions);
  
  // do IWLS for at most 30 iterations and unfulfilled stopping criterion
  while ((iter++ < maxIter) && (! converged))
  {
    // compute the pseudo-observations and corresponding sqrt(weights) from the linear predictor
    AVector pseudoObs(nObs);
    AVector sqrtWeights(invSqrtDispersions);
    
#pragma omp parallel for
    for(PosInt i = 0; i < nObs; ++i)
    {
      double mu = config.link->linkinv(results.linPred(i));
      double dmudEta = config.link->mu_eta(results.linPred(i));
      
      pseudoObs(i) = results.linPred(i) - config.offsets(i) + (response(i) - mu) / dmudEta;
      sqrtWeights(i) *= dmudEta / sqrt(config.distribution->variance(mu));
    }
    
    // calculate X'sqrt(W), which is needed twice
    AMatrix XtsqrtW = arma::trans(design) * arma::diagmat(sqrtWeights);
    
    // calculate the precision matrix Q by doing a rank update:
    // if full Bayes is used, then:
    // Q = tcrossprod(X'sqrt(W)) + 1/g * unscaledPriorPrec
    // if TBF are used, then:
    // Q = tcrossprod(X'sqrt(W))
    double scaleFactor = 0.0;
    results.qFactor = unscaledPriorPrec; //just zeros to set up matrix
    syrk(false,
         false,
         XtsqrtW,
         scaleFactor,
         results.qFactor);
    
    // decompose into Cholesky factor, Q = LL':
    int info = potrf(false,
                     results.qFactor);
    
    // check that no error occured
    if(info != 0)
    {
      std::ostringstream stream;
      stream << "Cholesky factorization Q = LL' got error code " << info <<
        " in IWLS iteration " << iter;

      throw std::domain_error(stream.str().c_str());
    }
    
    // save the old coefficients vector
    AVector coefs_old = results.coefs;
    
    // the rhs of the equation Q * m = rhs   or    R'R * m = rhs
    pseudoObs = arma::diagmat(sqrtWeights) * pseudoObs;
    results.coefs = XtsqrtW * pseudoObs;
    
    // note that we have some steps to go until the computation
    // of results.coefs is finished!
    
    // forward-backward solve LL' * v = rhs
    info = potrs(false,
                 results.qFactor,
                 results.coefs);
    
    // check that no error occured
    if(info != 0)
    {
      std::ostringstream stream;
      stream << "Forward-backward solve got error code " << info <<
        " in IWLS iteration " << iter;

      throw std::domain_error(stream.str().c_str());
    }
    
    // the new linear predictor is
    results.linPred = design * results.coefs + config.offsets;
    
    // compare on the coefficients scale, but not in the first iteration where
    // it is not clear from where coefs_old came. Be safe and always
    // decide for non-convergence in this case.
    converged = (iter > 1) ? (criterion(coefs_old, results.coefs) < epsilon) : false;
    finalWeights = sqrtWeights;
  }
  
  // do not (!)
  // warn if IWLS did not converge within the maximum number of iterations
  // because the maximum number of iterations can be set by user of this function.
  
  // compute log precision determinant
  results.logPrecisionDeterminant = 2.0 * arma::as_scalar(arma::sum(arma::log(arma::diagvec(results.qFactor))));
  
  
  //to calculate the observed Information we need the dispersion
  double dispersion;
  if( config.familyString == "poisson" || config.familyString == "binomial" ){
    dispersion = 1;
  } else {
    dispersion = dot(finalWeights, arma::square(response - results.linPred))/(nObs-results.coefs.n_elem);
  }
  
  
  AMatrix observed = arma::trans(design) *  arma::diagmat(arma::square(finalWeights)) * design / dispersion;
  
  
  AVector residuals = arma::square(response - results.linPred);
  
  return(observed);
}

/*
 * zdensity.h
 *
 *  Created on: 16.11.2009
 *      Author: daniel
 */

#ifndef IWLS_H_
#define IWLS_H_

#include "design.h"
#include "types.h"


// only one parameter set for the GLM
struct Parameter
{
    // ctr
    Parameter(const AVector& coefs,
              double z) :
                  coefs(coefs),
                  z(z)
                  {
                  }

    // default ctr
    Parameter(PosInt nCoefs) :
        coefs(nCoefs),
        z(R_NaReal)
        {
        }

    // the sampled regression coefficients (including the intercept)
    AVector coefs;

    // the sampled log covariance factor
    double z;
};




// all info from the iwls results
struct IwlsResults
{
    // ctr
    IwlsResults(const AVector& linPred,
                PosInt nCoefs) :
        linPred(linPred),
        coefs(nCoefs),
        qFactor(nCoefs, nCoefs)
        {
        }

    // default ctr
    IwlsResults(PosInt nObs,
                PosInt nCoefs) :
        linPred(nObs),
        coefs(nCoefs),
        qFactor(nCoefs, nCoefs)
        {
        }

    // the linear predictor (including offsets!)
    AVector linPred;

    // the corresponding coefficient vector,
    AVector coefs;

    // lower-triangular Cholesky factor of the precision matrix
    AMatrix qFactor;

    // the log determinant of the precision matrix
    double logPrecisionDeterminant;
};


// 03/07/2013: add offsets

class Iwls {

public:
    // constructor: constructs the Iwls object for given model and data and
    // start linear predictor
    Iwls(const ModelPar &mod,
         const DataValues& data,
         const FpInfo& fpInfo,
         const UcInfo& ucInfo,
         const FixInfo& fixInfo,
         const GlmModelConfig& config,
         const AVector& linPredStart,
         bool conditional,
         double epsilon,
         bool debug,
         bool tbf);

    // do the Iwls algorithm for a given covariance factor g and current linear predictor
    // linPred,
    // until convergence or until the maximum number of iterations is reached.
    // so also only one iwls step can be performed with this function.
    // Note that the linear predictor is the sum of X^T * beta and the vector of offsets.
    // returns the number of iterations.
    PosInt
    startWithLastLinPred(PosInt maxIter,
                         double g);

    // do the Iwls algorithm for a given covariance factor g and new start linear predictor
    // linPredStart.
    PosInt
    startWithNewLinPred(PosInt maxIter,
                        double g,
                        const AVector& linPredStart);

    // do the Iwls algorithm for a given covariance factor g and new start coefficients vector
    // coefsStart.
    PosInt
    startWithNewCoefs(PosInt maxIter,
                      double g,
                      const AVector& coefsStart);


    // compute the log of the (unnormalized)
    // posterior density for a given parameter consisting of the coefficients vector and z
    double
    computeLogUnPosteriorDens(const Parameter& sample) const;

    // compute the deviance of the current model, which in R is done by the glm.fit function
    // This is required to compute the TBF.
    // Note that this changes the Iwls object, because it iterates until convergence
    // or until the maximum number of iterations has been reached.
    double
    computeDeviance(PosInt maxIter);

    // getter for results
    IwlsResults
    getResults() const
    {
        return results;
    }

    // Get the fisher information for the desired model
    AMatrix getInformation(PosInt maxIter,
                           PosInt nObs,
                           AVector invSqrtDispersions,
                           IwlsResults results,
                           const GlmModelConfig& config,
                           const AVector& response,
                           const AMatrix design,
                           double epsilon,
                           AMatrix unscaledPriorPrec
    );
    
    // this can be public:

    // design matrix for this model
    const AMatrix design;

    // dimension including the intercept ("ncol(design)" in R syntax)
    const PosInt nCoefs;

    // is this the null model?
    const bool isNullModel;

    // use a fixed z?
    const bool useFixedZ;

    // number of observations
    const PosInt nObs;


private:


    // the log of the determinant of the crossproduct of scaledDesignWithoutIntercept
    // This is B'(dispersions)^(-1)B.
    double logScaledDesignWithoutInterceptCrossprodDeterminant;

    // the response vector
    const AVector& response;

    // also needed in function calls (mean, variance and other glm functions)
    const GlmModelConfig& config;

    // This is diag(dispersions)^(-1/2), use diagmat to interpret it as diagonal matrix!
    AVector invSqrtDispersions;

    // unscaled prior precision matrix R^-1 = blockDiag(0, 1/c B'(dispersions)^(-1)B) (without g^-1)
    AMatrix unscaledPriorPrec;

    // container for the results of the iwls computation:
    IwlsResults results;

    // the convergence epsilon
    const double epsilon;

    // status messages??
    // const bool verbose;

    // use TBF methodology?
    const bool tbf;
};


#endif /* IWLS_H_ */

/*
 * linalgInterface.cpp
 *
 *  Created on: 10.12.2010
 *      Author: daniel
 */

#ifndef  USE_FC_LEN_T
# define USE_FC_LEN_T
#endif

#include <cassert>
#define ARMA_BLAS_CAPITALS
#define ARMA_LAPACK_CAPITALS
#include "linalgInterface.h"

#include <Rconfig.h>
#include <R_ext/Lapack.h>
#include <R_ext/BLAS.h>

#ifndef FCONE
# define FCONE
#endif

// constants:
static const double doubleOne = 1.0;
static const int intOne = 1;



// triangular solve of L * x = R
// where L can be provided lower or upper-triangular and be transposed.
// the solution is directly written into R.
void
trs(const bool upper,
    const bool transpose,
    const AMatrix& L,
    AMatrix& R)
{
    const char* side = "L";
    const char* uplo = upper ? "U" : "L";
    const char* transa = transpose ? "T" : "N";
    const char* diag = "N";

    const int m = R.n_rows;
    const int n = R.n_cols;
    assert(static_cast<PosInt>(m) == L.n_rows);

    F77_CALL(dtrsm)(side,
                    uplo,
                    transa,
                    diag,
                    & m,
                    & n,
                    & doubleOne,
                    L.memptr(),
                    & m,
                    R.memptr(),
                    & m FCONE FCONE FCONE FCONE);
}

// Cholesky decomposition of (symmetric) A,
// which can either be provided in lower or upper-triangular storage.
// Result will be in the same layout.
// Returns an error code which should be zero if all went well.
int
potrf(const bool upper,
      AMatrix& A)
{
    const char* uplo = upper ? "U" : "L";
    const int n = A.n_rows;
    assert(A.is_square());
    int info = 0;

    F77_CALL(dpotrf)(uplo,
                     & n,
                     A.memptr(),
                     & n,
                     & info FCONE);

    return info;
}

// Solve the system LL' * x = R
// Instead of lower-triangular L also the upper-triangular form can be provided.
// The solution is directly written into R.
// Returns an error code which should be zero if all went well.
int
potrs(const bool upper,
      const AMatrix& L,
      AMatrix& R)
{
    const char* uplo = upper ? "U" : "L";
    const int n = L.n_rows;
    assert(L.is_square());
    assert(static_cast<PosInt>(n) == R.n_rows);
    const int nrhs = R.n_cols;
    int info = 0;

    F77_CALL(dpotrs)(uplo,
                     & n,
                     & nrhs,
                     L.memptr(),
                     & n,
                     R.memptr(),
                     & n,
                     & info FCONE);

    return info;
}

// Do a symmetric rank k update of C:
// C := A * A' + beta * C
// where C must be symmetric and can be provided in lower or upper-triangular storage.
// Result will be in the same layout.
// If transpose == true, then the crossproduct will be added, i.e., C := A' * A + beta*C.
void
syrk(const bool upper,
     const bool transpose,
     const AMatrix& A,
     const double beta,
     AMatrix& C)
{
    const char* uplo = upper ? "U" : "L";
    const char* trans = transpose ? "T" : "N";
    const int n = C.n_rows;
    assert(C.is_square());
    const int k = transpose ? A.n_rows : A.n_cols;
    const int lda = transpose ? k : n;

    F77_CALL(dsyrk)(uplo,
                    trans,
                    & n,
                    & k,
                    & doubleOne,
                    A.memptr(),
                    & lda,
                    & beta,
                    C.memptr(),
                    & n FCONE FCONE);
}

// Do a triangular matrix-vector multiplication:
// x := A*x,   or   x := A'*x,
//
// where x is an n element vector and  A is an n by n upper or lower triangular matrix.
void
trmv(const bool upper,
     const bool transpose,
     const AMatrix& A,
     AVector& x)
{
    const char* uplo = upper ? "U" : "L";
    const char* trans = transpose ? "T" : "N";
    const char* diag = "N";
    const int n = A.n_rows;

    F77_CALL(dtrmv)(uplo,
                    trans,
                    diag,
                    & n,
                    A.memptr(),
                    & n,
                    x.memptr(),
                    & intOne FCONE FCONE FCONE);
}





/*
 * optimize.cpp
 *
 *  Created on: 08.12.2009
 *      Author: daniel
 */

#include "optimize.h"
#include "rcppExport.h"
#include "functionWraps.h"

using namespace Rcpp;

// ***************************************************************************************************//

// just an R interface to the brent optimization routine, for regression testing purposes.
// [[Rcpp::export]]
SEXP
cpp_optimize(SEXP R_function,  SEXP R_minx, SEXP R_maxx, SEXP R_precision)
{
    // extract function
    // R_interface = CDR(R_interface);
    // SEXP R_function = CAR(R_interface);
    // 
    // // constraints on the argument
    // R_interface = CDR(R_interface);
    // SEXP R_minx = CAR(R_interface);
    // 
    // R_interface = CDR(R_interface);
    // SEXP R_maxx= CAR(R_interface);
    // 
    // // and the settings
    // R_interface = CDR(R_interface);
    // SEXP R_precision = CAR(R_interface);

    // wrap the R function to a cached function
    RFunction fun(R_function);
    CachedFunction<RFunction> cachedFun(fun);

    // then minimize (with constraints)
    Brent<CachedFunction<RFunction> > brent(cachedFun,
                                            Rf_asReal(R_minx),
                                            Rf_asReal(R_maxx),
                                            Rf_asReal(R_precision));

    double xMin = brent.minimize();

    // now the inverse Hessian at the minimum
    AccurateNumericInvHessian<CachedFunction<RFunction> > funInvHess(cachedFun);
    double invHessMin = funInvHess(xMin);

    // pack results into R list
    return List::create(_["par"] = xMin,
                        _["inv.hessian"] = invHessMin,
                        _["evaluations"] = cachedFun.getCache().convert2list());
}

// ***************************************************************************************************//

// End of file.

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
NumericMatrix predBMAcpp(NumericMatrix SurvMat, NumericMatrix LpMat, NumericVector WtVec) {
  
  int nModels = SurvMat.nrow();
  int nTimes = SurvMat.ncol();
  int nObs = LpMat.nrow();
  
  // arma::mat Pred(nTimes, nObs) //nTimes rows and nObs columns
  Rcpp::NumericMatrix Pred(nTimes, nObs); //nTimes rows and nObs columns
  
  for(int i=0; i < nModels; i++){
    for(int t=0; t < nTimes; t++){
      for(int Ob=0; Ob < nObs; Ob++){
        double S = SurvMat(i,t);
        double eLP = LpMat(Ob,i);
        Pred(t,Ob) = Pred(t,Ob) +  WtVec[i] * pow(S,eLP);
      }
    }
    //Rprintf("Model %d of %d",i,nModels);
  }
  
  return Pred;
}


/*
 * sampleGlm.cpp
 *
 *  Created on: 10.12.2009
 *      Author: daniel
 *      
 *      13/07/2015 Replace assert() with Rccp:Stop()
 */

#include "rcppExport.h"
#include "combinatorics.h"
#include "dataStructure.h"
#include "types.h"
#include "iwls.h"
#include "design.h"
#include "coxfit.h"
#include "bfgs.h"
#include "optimize.h"
#include "fpUcHandling.h"
#include "linalgInterface.h"
//#include <cassert>

#ifdef _OPENMP
#include <omp.h>
#endif

using namespace Rcpp;

// ***************************************************************************************************//

struct MarginalZ
{
    MarginalZ(const RFunction& logDens,
              const RFunction& gen) :
                  logDens(logDens),
                  gen(gen)
                  {
                  }


    const RFunction logDens;
    const RFunction gen;
};

// ***************************************************************************************************//

struct Options
{
    Options(bool estimateMargLik,
            bool verbose,
            bool debug,
            bool isNullModel,
            bool useFixedZ,
            bool tbf,
            bool doGlm,
            PosInt iterations,
            PosInt burnin,
            PosInt step) :
        estimateMargLik(estimateMargLik), verbose(verbose),
                debug(debug), isNullModel(isNullModel), useFixedZ(useFixedZ),
                tbf(tbf), doGlm(doGlm),
                nSamples(ceil((iterations - burnin) * 1.0 / step)),
                iterations(iterations), burnin(burnin),
                step(step)
    {
    }

    const bool estimateMargLik;
    const bool verbose;
    const bool debug;
    const bool isNullModel;
    const bool useFixedZ;
    const bool tbf;
    const bool doGlm;

    const PosInt nSamples;
    const PosInt iterations;
    const PosInt burnin;
    const PosInt step;
};

// ***************************************************************************************************//

// this is just for being sure that the memory is returned correctly even in case
// of an error or user interrupt from R.
struct Fitter
{
    Fitter() :
        iwlsObject(0),
        coxfitObject(0)
    {}

    ~Fitter()
    {
        delete iwlsObject;
        delete coxfitObject;
    }

    Iwls * iwlsObject;
    Coxfit * coxfitObject;
};



// ***************************************************************************************************//


class Mcmc
{

public:
    // ctr
    Mcmc(const MarginalZ& marginalz, PosInt nObs, PosInt nCoefs) :
        sample(nCoefs),
        proposalInfo(nObs, nCoefs),
        marginalz(marginalz)
        {
        }

    // the current parameter sample
    Parameter sample;

    // the unnormalized log posterior of this sample
    double logUnPosterior;

    // info about the normal proposal distribution given the sampled z
    IwlsResults proposalInfo;

    // compute the log of the normalized proposal density when the z log density is provided
    // normalize correctly in order not to get problems (perhaps) with the Chib-Jeliazkov estimate
    // computation.
    double
    computeLogProposalDens() const
    {
        // Be careful: qFactor is in fact lower-triangular, so a simple multiplication would fail!
        // use instead directly a BLAS routine for this multiplication.
        AVector tmp = sample.coefs - proposalInfo.coefs;
        trmv(false, true, proposalInfo.qFactor, tmp);

        return 0.5 * (proposalInfo.logPrecisionDeterminant - arma::dot(tmp, tmp)) -
               M_LN_SQRT_2PI * proposalInfo.qFactor.n_rows +
               marginalz.logDens(sample.z);
    }

    // non-default assignment operator
    Mcmc&
    operator=(const Mcmc& rhs)
    {
        if(this == &rhs)
        {
            return *this;
        }
        else
        {
            sample = rhs.sample;
            logUnPosterior = rhs.logUnPosterior;
            proposalInfo = rhs.proposalInfo;

            return *this;
        }
    }


private:
    // the marginal z info: same for all Mcmc objects,
    // therefore it is not assigned by the assignment operator
    const MarginalZ marginalz;
    // important: copy the object, because otherwise (reference/pointer)
    // we are not sure that the functions are still available if we do not use "new"
};

// ***************************************************************************************************//


struct Samples
{
    // constructor: basically allocates beta matrix
    Samples(PosInt nCoefs, PosInt nSamples) :
        coefsSamples(nCoefs, nSamples),
        nSaved(0)
        {
        }

    // save a sample consisting of coefs and z
    void
    storeParameters(const Parameter& sample)
    {
        coefsSamples.col(nSaved++) = sample.coefs;
        zSamples.push_back(sample.z);
    }

    // save terms for marginal likelihood estimate
    void
    storeMargLikTerms(double num, double denom)
    {
        numerator.push_back(num);
        denominator.push_back(denom);
    }

    // output everything to an R list
    List
    convert2list() const;

private:
    // nCoefs x nSamples:
    AMatrix coefsSamples;

    // counts the number of saved parameters, so that we know where to store the
    // next coefficients vector
    PosInt nSaved;

    // is gradually extended:
    MyDoubleVector zSamples;

    // possibly stays empty if not required by the user:
    // the numerator and denominator terms for the marginal likelihood estimate
    MyDoubleVector numerator;
    MyDoubleVector denominator;
};

List
Samples::convert2list() const
{
    return List::create(_["coefficients"] = coefsSamples,
                        _["z"] = zSamples,
                        _["margLikNumerator"] = numerator,
                        _["margLikDenominator"] = denominator);
}


// ***************************************************************************************************//


// get a vector with normal variates from N(mean, sd^2)
AVector
drawNormalVariates(PosInt n, double mean, double sd)
{
    AVector ret(n);

    // use R's random number generator
    GetRNGstate();

    for (PosInt i = 0; i < n; ++i)
    {
        ret(i) = Rf_rnorm(mean, sd);
    }

    // no RNs required anymore
    PutRNGstate();

    return ret;
}

// draw a single random normal vector from N(mean, (precisionCholeskyFactor * t(precisionCholeskyFactor))^(-1))
AVector
drawNormalVector(const AVector& mean,
                 const AMatrix& precisionCholeskyFactor)
{
    // get vector from N(0, I)
    AVector w = drawNormalVariates(mean.n_rows, // as many normal variates as required by the dimension.
                                   0.0,
                                   1.0);

    // then solve L' * ret = w, and overwrite w with the result:
    trs(false,
        true,
        precisionCholeskyFactor,
        w);

    // return the shifted vector
    return (w + mean);
}


// draw a single uniform random variable:
// be careful with the seed because the z generator function also uses it (via R)
double
unif()
{
    GetRNGstate();

    double ret = unif_rand();

    PutRNGstate();

    return ret;
}


// ***************************************************************************************************//


// R call is:
//
//    samples <- .External(cpp_sampleGlm,
//                         model,
//                         attrs$data,
//                         attrs$fpInfos,
//                         attrs$ucInfos,
//                         attrs$fixInfos,
//                         attrs$distribution,
//                         newdata,
//                         options,
//                         marginalz)




// [[Rcpp::export]]
SEXP
cpp_sampleGlm(      List rcpp_model,List rcpp_data, List rcpp_fpInfos, List rcpp_ucInfos,
                    List rcpp_fixInfos, List rcpp_distribution, List rcpp_searchConfig,
                    List rcpp_options, List rcpp_marginalz)
{
    // ----------------------------------------------------------------------------------
    // extract arguments
    // ----------------------------------------------------------------------------------

    // r_interface = CDR(r_interface);
    // List rcpp_model(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_data(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_fpInfos(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_ucInfos(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_fixInfos(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_distribution(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_searchConfig(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_options(CAR(r_interface));
    // 
    // r_interface = CDR(r_interface);
    // List rcpp_marginalz(CAR(r_interface));

    // ----------------------------------------------------------------------------------
    // unpack the R objects
    // ----------------------------------------------------------------------------------

    // data:
    const NumericMatrix n_x = rcpp_data["x"];
    const AMatrix x(n_x.begin(), n_x.nrow(),
                   n_x.ncol());

    const NumericMatrix n_xCentered = rcpp_data["xCentered"];
    const AMatrix xCentered(n_xCentered.begin(), n_xCentered.nrow(),
                           n_xCentered.ncol());

    const NumericVector n_y = rcpp_data["y"];
    const AVector y(n_y.begin(), n_y.size());

    const IntVector censInd = as<IntVector>(rcpp_data["censInd"]);

    // FP configuration:

    // vector of maximum fp degrees
    const PosIntVector fpmaxs = as<PosIntVector>(rcpp_fpInfos["fpmaxs"]);
    // corresponding vector of fp column indices
    const PosIntVector fppos = rcpp_fpInfos["fppos"];
    // corresponding vector of power set cardinalities
    const PosIntVector fpcards = rcpp_fpInfos["fpcards"];
    // names of fp terms
    const StrVector fpnames = rcpp_fpInfos["fpnames"];


    // UC configuration:

    const PosIntVector ucIndices = rcpp_ucInfos["ucIndices"];
    List rcpp_ucColList = rcpp_ucInfos["ucColList"];

    std::vector<PosIntVector> ucColList;
    for (R_len_t i = 0; i != rcpp_ucColList.length(); ++i)
    {
        ucColList.push_back(as<PosIntVector>(rcpp_ucColList[i]));
    }
    
    // fixed covariate configuration:
    
    const PosIntVector fixIndices = rcpp_fixInfos["fixIndices"];
    List rcpp_fixColList = rcpp_fixInfos["fixColList"];
    
    std::vector<PosIntVector> fixColList;
    for (R_len_t i = 0; i != rcpp_fixColList.length(); ++i)
    {
      fixColList.push_back(as<PosIntVector>(rcpp_fixColList[i]));
    }
    
    
    

    // distributions info:

    const double nullModelLogMargLik = as<double>(rcpp_distribution["nullModelLogMargLik"]);
    const double nullModelDeviance = as<double>(rcpp_distribution["nullModelDeviance"]);
    S4 rcpp_gPrior = rcpp_distribution["gPrior"];
    List rcpp_family = rcpp_distribution["family"];
    const bool tbf = as<bool>(rcpp_distribution["tbf"]);
    const bool doGlm = as<bool>(rcpp_distribution["doGlm"]);
    
    const double empiricalMean = as<double>(rcpp_distribution["yMean"]);
    const bool empiricalgPrior = as<bool>(rcpp_distribution["empiricalgPrior"]);
    
    // model search configuration:
    const bool useFixedc = as<bool>(rcpp_searchConfig["useFixedc"]);
    
    // options:

    const bool estimateMargLik = as<bool>(rcpp_options["estimateMargLik"]);
    const bool verbose = as<bool>(rcpp_options["verbose"]);
    const bool debug = as<bool>(rcpp_options["debug"]);
    const bool isNullModel = as<bool>(rcpp_options["isNullModel"]);
    const bool useFixedZ = as<bool>(rcpp_options["useFixedZ"]);
    const double fixedZ = as<double>(rcpp_options["fixedZ"]);
#ifdef _OPENMP
    const bool useOpenMP = as<bool>(rcpp_options["useOpenMP"]);
#endif

    S4 rcpp_mcmc = rcpp_options["mcmc"];
    const PosInt iterations = rcpp_mcmc.slot("iterations");
    const PosInt burnin = rcpp_mcmc.slot("burnin");
    const PosInt step = rcpp_mcmc.slot("step");


    // z density stuff:

    const RFunction logMarginalZdens(as<SEXP>(rcpp_marginalz["logDens"]));
    const RFunction marginalZgen(as<SEXP>(rcpp_marginalz["gen"]));


    // ----------------------------------------------------------------------------------
    // further process arguments
    // ----------------------------------------------------------------------------------

    // data:

     // only the intercept is always included, that is fixed, in the model
     IntSet fixedCols;
     fixedCols.insert(1);

     // totalnumber is set to 0 because we do not care about it.
     const DataValues data(x, xCentered, y, censInd, 0, fixedCols);

     // FP configuration:
     const FpInfo fpInfo(fpcards, fppos, fpmaxs, fpnames, x);

     // UC configuration:

     // determine sizes of the UC groups, and the total size == maximum size reached together by all
     // UC groups.
     PosIntVector ucSizes;
     PosInt maxUcDim = 0;
     for (std::vector<PosIntVector>::const_iterator cols = ucColList.begin(); cols != ucColList.end(); ++cols)
     {
         PosInt thisSize = cols->size();

         maxUcDim += thisSize;
         ucSizes.push_back(thisSize);
     }
     const UcInfo ucInfo(ucSizes, maxUcDim, ucIndices, ucColList);

  
     // fix configuration:  
     
     // determine sizes of the fix groups, and the total size == maximum size reached together by all
     // UC groups.
     PosIntVector fixSizes;
     PosInt maxFixDim = 0;
     for (std::vector<PosIntVector>::const_iterator cols = fixColList.begin(); cols != fixColList.end(); ++cols)
     {
       PosInt thisSize = cols->size();
       
       maxFixDim += thisSize;
       fixSizes.push_back(thisSize);
     }
     const FixInfo fixInfo(fixSizes, maxFixDim, fixIndices, fixColList);
     
     
     
     
     
     // model configuration:
     GlmModelConfig config(rcpp_family, nullModelLogMargLik, nullModelDeviance, exp(fixedZ), rcpp_gPrior,
                           data.response, debug, useFixedc, empiricalMean, empiricalgPrior);


     // model config/info:
     const Model thisModel(ModelPar(rcpp_model["configuration"],
                                   fpInfo),
                          GlmModelInfo(as<List>(rcpp_model["information"])));


     // the options
     const Options options(estimateMargLik,
                           verbose,
                           debug,
                           isNullModel,
                           useFixedZ,
                           tbf,
                           doGlm,
                           iterations,
                           burnin,
                           step);

     // marginal z stuff
     const MarginalZ marginalZ(logMarginalZdens,
                               marginalZgen);


     // use only one thread if we do not want to use openMP.
#ifdef _OPENMP
     if(! useOpenMP)
     {
         omp_set_num_threads(1);
     } else {
         omp_set_num_threads(omp_get_num_procs());
     }
#endif


     // ----------------------------------------------------------------------------------
     // prepare the sampling
     // ----------------------------------------------------------------------------------

     Fitter fitter;
     int nCoefs;

     if(options.doGlm)
     {
         // construct IWLS object, which can be used for all IWLS stuff,
         // and also contains the design matrix etc
         fitter.iwlsObject = new Iwls(thisModel.par,
                                      data,
                                      fpInfo,
                                      ucInfo,
                                      fixInfo,
                                      config,
                                      config.linPredStart,
                                      options.useFixedZ,
                                      EPS,
                                      options.debug,
                                      options.tbf);

         nCoefs = fitter.iwlsObject->nCoefs;

         // check that we have the same answer about the null model as R
         //assert(fitter.iwlsObject->isNullModel == options.isNullModel);
         if(fitter.iwlsObject->isNullModel != options.isNullModel){
           Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: isNullModel != options.isNullModel");
         } 
     }
     else
     {
         AMatrix design = getDesignMatrix(thisModel.par, data, fpInfo, ucInfo, fixInfo, false);
         fitter.coxfitObject = new Coxfit(data.response,
                                          data.censInd,
                                          design,
                                          config.weights,
                                          config.offsets,
                                          1);

         // the number of coefficients (here it does not include the intercept!!)
         nCoefs = design.n_cols;

         // check that we do not have a null model here:
         // assert(nCoefs > 0);
         if(nCoefs <= 0){
           Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: nCoefs <= 0");
         } 
     }


     // allocate sample container
     Samples samples(nCoefs, options.nSamples);

     // count how many proposals we have accepted:
     PosInt nAccepted(0);

     // at what z do we start?
     double startZ = useFixedZ ? fixedZ : thisModel.info.zMode;

     // start container with current things
     Mcmc now(marginalZ, data.nObs, nCoefs);

     if(doGlm)
     {
         // get the mode for beta given the mode of the approximated marginal posterior as z
         // if TBF approach is used, this will be the only time the IWLS is used,
         // because we only need the MLE and the Cholesky factor of its
         // precision matrix estimate, which do not depend on z.
         PosInt iwlsIterations = fitter.iwlsObject->startWithNewLinPred(40,
                                                                        // this is the corresponding g
                                                                        exp(startZ),
                                                                        // and the start value for the linear predictor is taken from the Glm model config
                                                                        config.linPredStart);

         // echo debug-level message?
         if(options.debug)
         {
             Rprintf("\ncpp_sampleGlm: Initial IWLS for high density point finished after %d iterations",
                     iwlsIterations);
         }

         // this is the current proposal info:
         now.proposalInfo = fitter.iwlsObject->getResults();

         // and this is the current parameters sample:
         now.sample = Parameter(now.proposalInfo.coefs,
                                startZ);

         if(options.tbf)
         {
             // we will not compute this in the TBF case:
             now.logUnPosterior = R_NaReal;

             // start to compute the variance of the intercept parameter:

             // here the inverse cholesky factor of the precision matrix will
             // be stored. First, it's the identity matrix.
             AMatrix inverseQfactor = arma::eye(now.proposalInfo.qFactor.n_rows,
                                                now.proposalInfo.qFactor.n_cols);

             // do the inversion
             trs(false,
                 false,
                 now.proposalInfo.qFactor,
                 inverseQfactor);

             // now we can compute the variance of the intercept estimate:
             const AVector firstCol = inverseQfactor.col(0);
             const double interceptVar = arma::dot(firstCol, firstCol);

             // ok, now alter the qFactor appropriately to reflect the
             // independence assumption between the intercept estimate
             // and the other coefficients estimates
             now.proposalInfo.qFactor.col(0) = arma::zeros<AVector>(now.proposalInfo.qFactor.n_rows);
             now.proposalInfo.qFactor(0, 0) = sqrt(1.0 / interceptVar);
         }
         else
         {
             // compute the (unnormalized) log posterior of the proposal
             now.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(now.sample);
         }
     }
     else
     {
         PosInt coxfitIterations = fitter.coxfitObject->fit();
         CoxfitResults coxResults = fitter.coxfitObject->finalizeAndGetResults();
         fitter.coxfitObject->checkResults();

         // echo debug-level message?
         if(options.debug)
         {
             Rprintf("\ncpp_sampleGlm: Cox fit finished after %d iterations",
                     coxfitIterations);
         }

         // we will not compute this in the TBF case:
         now.logUnPosterior = R_NaReal;

         // compute the Cholesky factorization of the covariance matrix
         int info = potrf(false,
                          coxResults.imat);

         // check that all went well
         if(info != 0)
         {
             std::ostringstream stream;
             stream << "dpotrf(coxResults.imat) got error code " << info << "in sampleGlm";
             throw std::domain_error(stream.str().c_str());
         }

         // compute the precision matrix, using the Cholesky factorization
         // of the covariance matrix
         now.proposalInfo.qFactor = arma::eye(now.proposalInfo.qFactor.n_rows,
                                              now.proposalInfo.qFactor.n_cols);
         info = potrs(false,
                      coxResults.imat,
                      now.proposalInfo.qFactor);

         // check that all went well
         if(info != 0)
         {
             std::ostringstream stream;
             stream << "dpotrs(coxResults.imat, now.proposalInfo.qFactor) got error code " << info << "in sampleGlm";
             throw std::domain_error(stream.str().c_str());
         }

         // compute the Cholesky factorization of the precision matrix
         info = potrf(false,
                      now.proposalInfo.qFactor);

         // check that all went well
         if(info != 0)
         {
             std::ostringstream stream;
             stream << "dpotrf(now.proposalInfo.qFactor) got error code " << info << "in sampleGlm";
             throw std::domain_error(stream.str().c_str());
         }

         // the MLE of the coefficients
         now.proposalInfo.coefs = coxResults.coefs;
     }

     // so the parameter object "now" is then also the high density point
     // required for the marginal likelihood estimate:
     const Mcmc highDensityPoint(now);

     // we accept this starting value, so initialize "old" with the same ones
     Mcmc old(now);

     // ----------------------------------------------------------------------------------
     // start sampling
     // ----------------------------------------------------------------------------------

     // echo debug-level message?
     if(options.debug)
     {
         if(tbf)
         {
             Rprintf("\ncpp_sampleGlm: Starting MC simulation");
         }
         else
         {
             Rprintf("\ncpp_sampleGlm: Starting MCMC loop");
         }
     }


     // i_iter starts at 1 !!
     for(PosInt i_iter = 1; i_iter <= options.iterations; ++i_iter)
     {
         // echo debug-level message?
         if(options.debug)
         {
             Rprintf("\ncpp_sampleGlm: Starting iteration no. %d", i_iter);
         }

         // ----------------------------------------------------------------------------------
         // store the proposal
         // ----------------------------------------------------------------------------------

         // sample one new log covariance factor z (other arguments than 1 are not useful
         // with the current setup of the RFunction wrapper class)
         now.sample.z = marginalZ.gen(1);

         if(options.tbf)
         {
             if(options.isNullModel)
             {
                 // note that we do not encounter this in the Cox case
                 // assert(options.doGlm);
                 if(!options.doGlm){
                   Rcpp::stop("sampleGlm.cpp:cpp_sampleGlm: options.doGlm should be TRUE");
                 } 

                 // draw the proposal coefs, which is here just the intercept
                 now.sample.coefs = drawNormalVector(now.proposalInfo.coefs,
                                                     now.proposalInfo.qFactor);

             }
             else
             {   // here we have at least one non-intercept coefficient

                 // get vector from N(0, I)
                 AVector w = drawNormalVariates(now.proposalInfo.coefs.n_elem,
                                                0.0,
                                                1.0);

                 // then solve L' * ret = w, and overwrite w with the result:
                 trs(false,
                     true,
                     now.proposalInfo.qFactor,
                     w);

                 // compute the shrinkage factor t = g / (g + 1)
                 const double g = exp(now.sample.z);
                
                //Previously used g directly, but if g=inf we need to use the limit
                 // const double shrinkFactor = g / (g + 1.0);
                const double shrinkFactor = std::isinf(g) ? 1 : g / (g + 1.0);
                 
                 // scale the variance of the non-intercept coefficients
                 // with this factor.
                 // In the Cox case: no intercept present, so scale everything
                 int startCoef = options.doGlm ? 1 : 0;

                 w.rows(startCoef, w.n_rows - 1) *= sqrt(shrinkFactor);

                 // also scale the mean of the non-intercept coefficients
                 // appropriately:
                 // In the Cox case: no intercept present, so scale everything
                 now.sample.coefs = now.proposalInfo.coefs;
                 now.sample.coefs.rows(startCoef, now.sample.coefs.n_rows - 1) *= shrinkFactor;

                 // so altogether we have:
                 now.sample.coefs += w;
             }
             ++nAccepted;
         }
         else // the generalized hyper-g prior case
         {
             // do 1 IWLS step, starting from the last linear predictor and the new z
             // (here the return value is not very interesting, as it must be 1)
             fitter.iwlsObject->startWithNewCoefs(1,
                                                  exp(now.sample.z),
                                                  now.sample.coefs);

             // get the results
             now.proposalInfo = fitter.iwlsObject->getResults();

             // draw the proposal coefs:
             now.sample.coefs = drawNormalVector(now.proposalInfo.coefs,
                                                 now.proposalInfo.qFactor);

             // compute the (unnormalized) log posterior of the proposal
             now.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(now.sample);

             // ----------------------------------------------------------------------------------
             // get the reverse jump normal density
             // ----------------------------------------------------------------------------------

             // copy the old Mcmc object
             Mcmc reverse(old);

             // do again 1 IWLS step, starting from the sampled linear predictor and the old z
             fitter.iwlsObject->startWithNewCoefs(1,
                                          exp(reverse.sample.z),
                                          now.sample.coefs);

             // get the results for the reverse jump Gaussian:
             // only the proposal has changed in contrast to the old container,
             // the sample stays the same!
             reverse.proposalInfo = fitter.iwlsObject->getResults();


             // ----------------------------------------------------------------------------------
             // compute the proposal density ratio
             // ----------------------------------------------------------------------------------

             // first the log of the numerator, i.e. log(f(old | new)):
             double logProposalRatioNumerator = reverse.computeLogProposalDens();

             // second the log of the denominator, i.e. log(f(new | old)):
             double logProposalRatioDenominator = now.computeLogProposalDens();

             // so the log proposal density ratio is
             double logProposalRatio = logProposalRatioNumerator - logProposalRatioDenominator;

             // ----------------------------------------------------------------------------------
             // compute the posterior density ratio
             // ----------------------------------------------------------------------------------

             double logPosteriorRatio = now.logUnPosterior - old.logUnPosterior;

             // ----------------------------------------------------------------------------------
             // accept or reject proposal
             // ----------------------------------------------------------------------------------

             double acceptanceProb = exp(logPosteriorRatio + logProposalRatio);

             if(unif() < acceptanceProb)
             {
                 old = now;

                 ++nAccepted;
             }
             else
             {
                 now = old;
             }
         }

         // ----------------------------------------------------------------------------------
         // store the sample?
         // ----------------------------------------------------------------------------------

         // if the burnin was passed and we are at a multiple of step beyond that, then store
         // the sample.
         if((i_iter > options.burnin) &&
            (((i_iter - options.burnin) % options.step) == 0))
         {
             // echo debug-level message
             if(options.debug)
             {
                 Rprintf("\ncpp_sampleGlm: Storing samples of iteration no. %d", i_iter);
             }

             // store the current parameter sample
             samples.storeParameters(now.sample);

             // ----------------------------------------------------------------------------------
             // compute marginal likelihood terms
             // ----------------------------------------------------------------------------------

             // compute marginal likelihood terms and save them?
             // (Note that the tbf bool is just for safety here,
             // the R function sampleGlm will set estimateMargLik to FALSE
             // when tbf is TRUE.)
             if(options.estimateMargLik && (! options.tbf))
             {
                 // echo debug-level message?
                 if(options.debug)
                 {
                     Rprintf("\ncpp_sampleGlm: Compute marginal likelihood estimation terms");
                 }

                 // ----------------------------------------------------------------------------------
                 // compute next term for the denominator
                 // ----------------------------------------------------------------------------------

                 // draw from the high density point proposal distribution
                 Mcmc denominator(highDensityPoint);
                 denominator.sample.z = marginalZ.gen(1);

                 fitter.iwlsObject->startWithNewLinPred(1,
                                                exp(denominator.sample.z),
                                                highDensityPoint.proposalInfo.linPred);

                 denominator.proposalInfo = fitter.iwlsObject->getResults();

                 denominator.sample.coefs = drawNormalVector(denominator.proposalInfo.coefs,
                                                             denominator.proposalInfo.qFactor);

                 // get posterior density of the sample
                 denominator.logUnPosterior = fitter.iwlsObject->computeLogUnPosteriorDens(denominator.sample);

                 // get the proposal density at the sample
                 double denominator_logProposalDensity = denominator.computeLogProposalDens();

                 // then the reverse stuff:
                 // first we copy again the high density point
                 Mcmc revDenom(highDensityPoint);

                 // but choose the new sampled coefficients as starting point
                 fitter.iwlsObject->startWithNewCoefs(1,
                                              exp(revDenom.sample.z),
                                              denominator.sample.coefs);
                 revDenom.proposalInfo = fitter.iwlsObject->getResults();

                 // so the reverse proposal density is
                 double revDenom_logProposalDensity = revDenom.computeLogProposalDens();


                 // so altogether the next term for the denominator is the following acceptance probability
                 double denominatorTerm = denominator.logUnPosterior - highDensityPoint.logUnPosterior +
                                          revDenom_logProposalDensity - denominator_logProposalDensity;
                 denominatorTerm = exp(fmin(0.0, denominatorTerm));

                 // ----------------------------------------------------------------------------------
                 // compute next term for the numerator
                 // ----------------------------------------------------------------------------------

                 // compute the proposal density of the current sample starting from the high density point
                 Mcmc numerator(now);

                 fitter.iwlsObject->startWithNewLinPred(1,
                                                exp(numerator.sample.z),
                                                highDensityPoint.proposalInfo.linPred);
                 numerator.proposalInfo = fitter.iwlsObject->getResults();

                 double numerator_logProposalDensity = numerator.computeLogProposalDens();

                 // then compute the reverse proposal density of the high density point when we start from the current
                 // sample
                 Mcmc revNum(highDensityPoint);

                 fitter.iwlsObject->startWithNewCoefs(1,
                                              exp(revNum.sample.z),
                                              now.sample.coefs);
                 revNum.proposalInfo = fitter.iwlsObject->getResults();

                 double revNum_logProposalDensity = revNum.computeLogProposalDens();

                 // so altogether the next term for the numerator is the following guy:
                 double numeratorTerm = exp(fmin(revNum_logProposalDensity,
                                                 highDensityPoint.logUnPosterior - now.logUnPosterior +
                                                 numerator_logProposalDensity));

                 // ----------------------------------------------------------------------------------
                 // finally store both terms
                 // ----------------------------------------------------------------------------------

                 samples.storeMargLikTerms(numeratorTerm, denominatorTerm);

             }
         }

         // ----------------------------------------------------------------------------------
         // echo progress?
         // ----------------------------------------------------------------------------------

         // echo debug-level message?
         if(options.debug)
         {
             Rprintf("\ncpp_sampleGlm: Finished iteration no. %d", i_iter);
         }

         if((i_iter % std::max(static_cast<int>(options.iterations / 100), 1) == 0) &&
             options.verbose)
         {
             // display computation progress at each percent
             Rprintf("-");

         } // end echo progress

     } // end MCMC loop


     // echo debug-level message?
     if(options.debug)
     {
         if(tbf)
         {
             Rprintf("\ncpp_sampleGlm: Finished MC simulation");
         }
         else
         {
             Rprintf("\ncpp_sampleGlm: Finished MCMC loop");
         }
     }


     // ----------------------------------------------------------------------------------
     // build up return list for R and return that.
     // ----------------------------------------------------------------------------------

     return List::create(_["samples"] = samples.convert2list(),
                         _["nAccepted"] = nAccepted,
                         _["highDensityPointLogUnPosterior"] = highDensityPoint.logUnPosterior);

} // end cpp_sampleGlm

// ***************************************************************************************************//

// End of sampleGlm.cpp


#include "zdensity.h"
#include <stdexcept>

#include "rcppExport.h"
#include "linalgInterface.h"
#include "coxfit.h"

// 03/07/2013: use offsets

// constructor
NegLogUnnormZDens::NegLogUnnormZDens(const ModelPar &mod,
                                     const DataValues& data,
                                     const FpInfo& fpInfo,
                                     const UcInfo& ucInfo,
                                     const FixInfo& fixInfo,
                                     const GlmModelConfig& config,
                                     // return the approximate *conditional* density f(y | z, mod) by operator()?
                                     // otherwise return the approximate unnormalized *joint* density f(y, z | mod).
                                     const Book& bookkeep,
                                     PosInt nIter) :
                                     mod(mod),
                                     fpInfo(fpInfo),
                                     config(config),
                                     bookkeep(bookkeep),
                                     linPredStart(config.linPredStart),
                                     iwlsObject(0),
                                     coxfitObject(0),
                                     nIter(nIter),
                                     modSize(mod.size(ucInfo, fixInfo)), 
                                     modResidualDeviance(R_NaReal)
{
    if(bookkeep.doGlm)
    {
        iwlsObject = new Iwls(mod, data, fpInfo, ucInfo, fixInfo, config,
                              config.linPredStart,
                              // take the same original start value for each model, but then update
                              // it inside the iwls object when new calls to the functor are made.
                              (bookkeep.useFixedg || bookkeep.empiricalBayes),
                              EPS, // take EPS as the convergence epsilon
                              bookkeep.debug,
                              bookkeep.tbf);

        if(bookkeep.tbf)
        {
            // compute the residual deviance for this model
            modResidualDeviance = config.nullModelDeviance - iwlsObject->computeDeviance(100);

            // echo detailed progress in debug mode
            if(bookkeep.debug)
            {
                Rprintf("\nNegLogUnnormZDens: Residual deviance of this model is %f", modResidualDeviance);
            }
        }

    }
    else
    {
        coxfitObject = new Coxfit(data.response,
                                  data.censInd,
                                  getDesignMatrix(mod, data, fpInfo, ucInfo, fixInfo, false),
                                  config.weights,
                                  config.offsets,
                                  1);

        // compute the residual deviance for this model
        modResidualDeviance = coxfitObject->computeResidualDeviance();

        // echo detailed progress in debug mode
        if(bookkeep.debug)
        {
            Rprintf("\nNegLogUnnormZDens: Residual deviance of this Cox model is %f", modResidualDeviance);
        }
    }
}

// try to get the TBF log marginal likelihood
double
NegLogUnnormZDens::getTBFLogMargLik() const
{
    double ret = R_NaReal;

    if(bookkeep.tbf)
    {
        // ask g-prior object to give log marginal likelihood
        // if a closed form is not available (as for most classes) then
        // NA is returned.
        ret = config.gPrior->getTBFLogMargLik(modResidualDeviance, modSize);
    } else {
        std::ostringstream stream;
        stream << "getTBFLogMargLik asked from NegLogUnnormZDens, but TBF methodology is not used!";
        throw std::domain_error(stream.str().c_str());
    }

    return ret;
}

// get the maximum log conditional marginal likelihood
// and put the local EB estimate into zMode
double
NegLogUnnormZDens::getTBFMaxLogCondMargLik(double& zMode) const
{
    double ret = R_NaReal;

    if(bookkeep.tbf)
    {
        if(modResidualDeviance > modSize)
        {
            double gMode = modResidualDeviance / modSize - 1.0;
            zMode = log(gMode);

            ret = - modSize / 2.0 * log1p(gMode) + gMode / (gMode + 1.0) * modResidualDeviance / 2.0;
        }
        else
        {
            zMode = R_NegInf;
            ret = 0.0;
        }
    } else {
        std::ostringstream stream;
        stream << "getTBFMaxLogCondMargLik asked from NegLogUnnormZDens, but TBF methodology is not used!";
        throw std::domain_error(stream.str().c_str());
    }

    return ret;
}

// call the function object
double
NegLogUnnormZDens::operator()(double z)
{
    // map back to the original covariance factor scale
    const double g = exp(z);

    // optional status message
    if(bookkeep.debug)
    {
        Rprintf("\nNegLogUnnormZDens: Computing function call NegLogUnnormZDens(%f) ...", z);
    }

    // if g is numerically zero, we cannot proceed
    if(g == 0.0)
    {
        std::ostringstream stream;
        stream << "g numerically zero";
        throw std::domain_error(stream.str().c_str());
    }

    // the return value will be placed in here:
    double ret = 0.0;

    // first consider the TBF case
    if(bookkeep.tbf)
    {
        if(bookkeep.debug)
        {
            Rprintf("\nNegLogUnnormZDens: Using TBF approach");
        }

        double logBF = - modSize / 2.0 * log1p(g) + g / (g + 1.0) * modResidualDeviance / 2.0;

        // Note that the following distinction is done *inside*
        // Iwls::computeLogUnPosteriorDens for the generalized hyper-g prior approach.
        if(bookkeep.useFixedg || bookkeep.empiricalBayes)
        {
            // return the negative conditional log marginal likelihood approximation, - log(f(y | z))
            ret = - logBF;
        }
        else
        {
            // return - log(f(y | z) f(z)) = - log(f(y, z)), the negative unnormalized log posterior of z
            double logGprior = config.gPrior->logDens(g) + z;
            ret = - logBF - logGprior;
        }
    }
    else // hyper-g prior
    {
        if(bookkeep.debug)
        {
            Rprintf("\nNegLogUnnormZDens: Using generalised hyper-g prior approach");
        }

        // protect against errors in IWLS and non-finite result
        try
        {
            // compute Gaussian approximation:
            PosInt requiredIter = iwlsObject->startWithLastLinPred(nIter, // iterate at most nIter times (because we want convergence)
                                                                  g);    // for this covariance factor, for the current linear predictor start.

            // if we did not converge in the maximum number of iterations, then start again from the original linear predictor,
            // and allow even more iterations.
            if(requiredIter > nIter)
            {
                PosInt higherIter = 2 * nIter;
                requiredIter = iwlsObject->startWithNewLinPred(higherIter,
                                                              g,
                                                              linPredStart);

                // if we still do not have converged, print a warning message if we are verbose.
                if(requiredIter > higherIter && bookkeep.debug)
                {
                    Rprintf("\nnNegLogUnnormZDens: IWLS did not converge in %d iterations (even after restart)!", higherIter);
                }

                // do not warn the user, because this need not be a serious problem.
            }

            if(bookkeep.debug)
            {
                Rprintf("\nNegLogUnnormZDens: finished after %d IWLS iterations", requiredIter);
            }

            // get iwls results
            const IwlsResults iwlsResults = iwlsObject->getResults();

            // then the return value is:
            ret = 0.5 * iwlsResults.logPrecisionDeterminant -
                    iwlsObject->nCoefs * M_LN_SQRT_2PI -    // This is dependent on the model dimension! (we had to add it here because
                    // computeLogUnPosteriorDens also contains now the analogous normalization constant.
                    iwlsObject->computeLogUnPosteriorDens(Parameter(iwlsResults.coefs, z));


            // the Raudenbush & Yang & Yosef correction to the Laplace approximation
            // in the canonical link case

            // Warning: this may not work yet for some reason for some data sets,
            // strange negative correctionFactor values can occur!
            // (both for the removed Fortran and for the actual C++ code...)
            if(bookkeep.higherOrderCorrection && config.canonicalLink)
            {

                // initialize E(T_4), E(T_6):
                // (excluding constant factors which are multiplied at the end)
                double exp_T4 = 0.0;
                double exp_T6 = 0.0;

                // for the sum over m_i^(3) * x_i * B_i:
                AVector k = arma::zeros(iwlsObject->nCoefs);

                // design matrix is also needed
                const AMatrix& design = iwlsObject->design;

                // iterate through the observations:
                for(PosInt i = 0; i < iwlsObject->nObs; ++i)
                {
                    // calculate the fitted probability and resulting derivatives m_i^(x)
                    // along the way.
                    const double mu = config.link->linkinv(iwlsResults.linPred(i));
                    double m3, m4, m6;

                    // see page 147 in Raudenbush et al. for the formulas of m3, m4, m6
                    if(config.familyString == "binomial")
                    {
                        const double m2 = mu * (1.0 - mu);
                        m3 = m2 * (1.0 - 2.0 * mu);
                        m4 = m2 * (1.0 - 6.0 * m2);
                        m6 = m4 * (1.0 - 12.0 * m2) - 12.0 * m3 * m3;
                    }
                    else if (config.familyString == "poisson")
                    {
                        m3 = mu;
                        m4 = mu;
                        m6 = mu;
                    }
                    else
                    {
                        Rf_error("Higher order correction not implemented for this family.");
                    }

                    // add to the sums:
                    AVector tmp = arma::trans(design.row(i));
                    trs(false, false, iwlsResults.qFactor, tmp);
                    const double B = arma::dot(tmp, tmp);
                    const double B2 = B * B;

                    exp_T4 += m4 * B2;
                    exp_T6 += m6 * B2 * B;
                    k += (m3 * B) * arma::trans(design.row(i));
                }

                // calculate k^T * Cov * k, and overwrite k with the intermediate result:
                trs(false, false, iwlsResults.qFactor, k);
                double exp_T3T3 = arma::dot(k, k);

                // So the correction factor for the conditional marginal likelihood is (with the new terms):
                double correctionFactor = - 1.0 / 8.0 * exp_T4 -
                        1.0 / 48.0 * exp_T6 +
                        5.0 / 24.0 * exp_T3T3;

                if(bookkeep.debug)
                {
                    Rprintf("\nNegLogUnnormZDens: Higher-order correction factor is %f", 1.0 + correctionFactor);
                }

                if(correctionFactor > -1.0)
                {
                    // since we return here the negative log of the conditional marg lik:
                    ret -= log1p(correctionFactor);
                } else {
                    Rf_warning("negative value for correction factor! We are not using the higher order correction here.");
                }

            } // end if(higherOrderCorrection)

            // check finiteness of return value
            if(! R_finite(ret))
            {
                std::ostringstream stream;
                stream << "NegLogUnnormZDens() got non-finite result " << ret << " for z=" << z;
                throw std::domain_error(stream.str().c_str());
            }
        }
        // catch errors in IWLS and non-finite result
        catch (std::domain_error& error)
        {
            if(bookkeep.debug)
            {
                Rprintf("For z=%f, the density value could not be computed because\n%s",
                        z, error.what());
            }
            Rf_warning("for z=%f, the density value could not be computed for the following model:\n%s\nCheck for near-collinearity of covariates.",
                       z, mod.print(fpInfo).c_str());

            // return NaN. This can be handled by the Brent optimize routine! It apparently replaces it (implicitely) by
            // the highest positive number.
            return R_NaN;
        }
    }

    // return value
    return ret;

}

1		#####################################################################################
2		## Author: Daniel Sabanes Bove [daniel . sabanesbove at* ifspm . uzh . ch]
3		## Project: Bayesian FPs for GLMs
4		##
5		## Time-stamp: <[getFpTransforms.R] by DSB Fre 15/06/2012 16:05 (CEST)>
6		##
7		## Description:
8		## Transform a variable according to FP transformation formula and attach proper
9		## names to the resulting design matrix.
10		##
11		## History:
12		## 06/01/2010 copy from package bfp, slightly pimp and add Roxygen stuff
13		## 15/06/2012 simplify %bt% documentation for new roxygen package
14		#####################################################################################
15
16
17		##' Box Tidwell transformation
18		##'
19		##' Simple function to apply the Box Tidwell transformation to a vector, when a (single) power is
20		##' provided.
21		##'
22		##' @param x the numeric vector
23		##' @param pow the single power
24		##' @return the transformed vector
25		##'
26		##' @name boxTidwell
27		##' @aliases boxTidwell '%bt%'
28		##' @keywords utilities internal
29		"%bt%" <- function(x,
30		pow) {
31		## checks
32	18x	stopifnot(
33	18x	identical(length(pow), 1L),
34	18x	is.numeric(x),
35	18x	is.numeric(pow)
36		)
37
38		## transformation
39	18x	if (pow != 0) {
40	16x	x^pow
41		} else { ## pow == 0
42	2x	log(x)
43		}
44		}
45
46
47		##' Get the FP transforms matrix of a given covariate vector
48		##'
49		##' Get the (centered) FP transforms matrix of a given covariate vector, when the corresponding
50		##' power vector (with at least one element) is provided.
51		##'
52		##' @param vec positive (== already shifted and scaled) column vector with proper colname
53		##' @param powers power vector with at least one element
54		##' @param center center the columns of the FP transforms matrix around zero? (default)
55		##' @return the FP transforms matrix with proper colnames.
56		##'
57		##' @keywords utilities internal
58		getFpTransforms <- function(vec,
59		powers,
60		center = TRUE) {
61		## internal helper function, only required here:
62	18x	getTransformName <- function(name, pow) {
63		## checks
64	18x	stopifnot(
65	18x	identical(length(pow), 1L),
66	18x	is.character(name)
67		)
68
69		## create name
70	18x	if (pow != 0) {
71	16x	paste(name, pow, sep = "^")
72	18x	} else { ## pow == 0
73	2x	paste0("log(", name, ")")
74		}
75		}
76
77		## get properties of arguments
78	18x	name <- colnames(vec)
79	18x	vec <- as.vector(vec)
80	18x	len <- length(vec)
81	18x	np <- length(powers)
82
83		## start return matrix
84	18x	ret <- matrix(nrow = len, ncol = np)
85	18x	retColnames <- character(np)
86
87		## begin of recursion:
88
89		## start with vector of ones
90	18x	lastCol <- 1
91
92		## and power "log"
93	18x	lastPow <- 0
94
95		## invariant: already numRepPow times was this power repeated
96	18x	numRepPow <- 0L
97
98		## invariant: about to write ith column
99	18x	for (i in seq_along(powers)) {
100		## extract this power into "pi",
101		## check if it is the same as the last power and (afterwards) if we are not at the first power.
102	18x	if ((pi <- powers[i]) == lastPow && i != 1L) {
103		## repeated powers case
104	!	numRepPow <- numRepPow + 1L
105
106		## so we apply the rule for repeated powers
107	!	lastCol <- lastCol * log(vec)
108
109		## the name is a bit complicated
110	!	retColnames[i] <-
111	!	if (pi == 0) {
112		## log was repeated
113	!	paste(getTransformName(name, 0),
114	!	numRepPow + 1L,
115	!	sep = "^"
116		)
117		} else {
118		## other power was repeated
119	!	tmp <- paste(getTransformName(name, pi),
120	!	getTransformName(name, 0),
121	!	sep = "*"
122		)
123
124	!	if (numRepPow > 1L) {
125	!	tmp <- paste(tmp, numRepPow, sep = "^")
126		}
127
128	!	tmp
129		}
130		} else {
131		## normal case without repeated power:
132
133		## vector results from Box Tidwell transform
134	18x	lastCol <- vec %bt% pi
135
136		## and the name is easy
137	18x	retColnames[i] <- getTransformName(name, pi)
138
139		## reset power invariants
140	18x	numRepPow <- 0L
141	18x	lastPow <- pi
142		}
143
144		## write the last column
145	18x	ret[, i] <- lastCol
146		}
147
148		## optionally center the transforms matrix
149	18x	if (isTRUE(center)) {
150	16x	ret <- scale(ret, center = TRUE, scale = FALSE)
151		}
152
153		## attach proper colnames
154	18x	colnames(ret) <- retColnames
155
156		## and finally return that.
157	18x	return(ret)
158		}

1		#####################################################################################
2		## Author: Daniel Sabanés Bové [daniel . sabanesbove at* ifspm . uzh . ch]
3		## Project: BFPs for GLMs
4		##
5		## Time-stamp: <[getMarginalZ.R] by DSB Mon 26/08/2013 17:19 (CEST)>
6		##
7		## Description:
8		## Construct a (smooth) marginal z density approximation from a model
9		## information list
10		##
11		## History:
12		## 17/02/2010 split off from sampleGlm and also export the function
13		## 25/02/2010 Different strategy: now potentially all four methods are tried
14		## for the approximation, and the user may specify the order.
15		## The normal approximation is no longer a special case which issued
16		## a warning; not it is just one approximation method among all.
17		## First try "spline", then "logspline", because sometimes this can remedy
18		## the "too close to 0" error with "spline".
19		## 12/04/2010 limit the computation time for pinv.new to prepare against
20		## infinite loops in this function.
21		## 15/05/2010 implement a very robust density approximation, which is just the
22		## linear interpolation of the saved points. This "linear" method
23		## differs from the other methods in that it does not depend on the
24		## Runuran generators.
25		## 17/05/2010 "linear" is now the default, because it is very robust and works
26		## nicely!
27		## 25/05/2010 now the "logDensVals" may contain NaN's, which we do not want to
28		## include in the construction of the approximation, so we discard
29		## these pairs early enough.
30		#####################################################################################
31
32
33		##' Construct a (smooth) marginal z density approximation from a model
34		##' information list
35		##'
36		##' @param info the model information list
37		##' @param method method for approximating the marginal density:
38		##' \describe{
39		##' \item{linear}{Linearly interpolate the points.}
40		##' \item{spline}{The saved points of the unnormalized density approximation are joined
41		##' by a \dQuote{monotonic} spline. The density is smoothed out to zero at the
42		##' tails. Since the spline might be slightly negative for extreme values, the positive part
43		##' is returned.}
44		##' \item{logspline}{The saved points of the log unnormalized density approximation are joined
45		##' by a \dQuote{monotonic} spline, which is then exponentiated.}
46		##' \item{normalspline}{A \dQuote{monotonic} spline is fitted to the differences of the saved
47		##' log density values and the log normal approximation. The resulting spline function is
48		##' exponentiated and then multiplied with the normal density.}
49		##' \item{normal}{Just take the normal approximation.}
50		##' This may also be a vector with more than one method names, to select the modify the preference
51		##' sequence: If the first method does not work, the second is tried and so on. The normal
52		##' approximation always \dQuote{works} (but may give bad results).
53		##' }
54		##' @param verbose Echo the chosen method? (not default)
55		##' @param plot produce plots of the different approximation steps? (not default)
56		##' @return a list with the log of the normalized density approximation (\dQuote{logDens}) and
57		##' the random number generator (\dQuote{gen}).
58		##'
59		##' @export
60		##' @keywords internal
61		getMarginalZ <- function(info,
62		method =
63		c(
64		"linear", "spline", "logspline",
65		"normalspline", "normal"
66		),
67		verbose = FALSE,
68		plot = FALSE) {
69		## get the (ordered) z
70	38x	zVals <- info$negLogUnnormZDensities$args
71	38x	zOrder <- order(zVals)
72	38x	zVals <- zVals[zOrder]
73
74		## the range of z
75	38x	zMin <- zVals[1L]
76	38x	zMax <- zVals[length(zVals)]
77
78		## get (roughly normalized) and ordered log density values
79	38x	logDensVals <- with(
80	38x	info,
81	38x	-negLogUnnormZDensities$vals - logMargLik
82		)
83	38x	logDensVals <- logDensVals[zOrder]
84
85		## remove pairs with NaN log density values
86	38x	isNaN <- is.nan(logDensVals)
87
88	38x	logDensVals <- logDensVals[!isNaN]
89	38x	zVals <- zVals[!isNaN]
90
91		## optionally plot that
92	38x	if (plot) {
93	!	par(mfrow = c(2, 2))
94	!	plot(zVals,
95	!	exp(logDensVals),
96	!	type = "o",
97	!	main = "roughly normalized original values"
98		)
99	!	abline(v = info$zMode)
100		}
101
102		## the approximating normal density is:
103	38x	normalDens <- function(z, log = FALSE) {
104	!	dnorm(
105	!	x = z,
106	!	mean = info$zMode,
107	!	sd = sqrt(info$zVar),
108	!	log = log
109		)
110		}
111
112		## show it if wished
113	38x	if (plot) {
114	!	curve(normalDens,
115	!	from = zMin, to = zMax,
116	!	main = "normal approximation",
117	!	n = 301L
118		)
119	!	abline(v = info$zMode)
120		}
121
122
123		## decide on the range of the spline function
124	38x	constant <- 0.2 * (zMax - zMin)
125	38x	extendedZVals <- c(
126	38x	zMin - constant,
127	38x	zVals,
128	38x	zMax + constant
129		)
130
131		## add zeroes to both ends of the density values
132		## to smooth out the approximation to zero.
133	38x	densVals <- c(
134	38x	0,
135	38x	exp(logDensVals),
136	38x	0
137		)
138
139		## grid where the approximation is checked
140	38x	extendedZGrid <- seq(
141	38x	from = min(extendedZVals),
142	38x	to = max(extendedZVals),
143	38x	length = 401L
144		)
145
146		## what are the possible methods for computing the unnormalized z density?
147	38x	possibleMethods <-
148	38x	expression(
149		## --------------------
150	38x	spline = {
151		## now compute the spline
152	!	cubicSplineFun <- splinefun(
153	!	x = extendedZVals,
154	!	y = densVals,
155	!	method = "monoH.FC"
156		)
157
158		## so the unnormalized z density approximation is
159	!	function(z, log = FALSE) {
160		## set everything outside the range to zero
161		## (unfortunately this is not an option for "splinefun")
162	!	ret <- ifelse(z > min(extendedZVals) & z < max(extendedZVals),
163	!	cubicSplineFun(z),
164	!	0
165		)
166
167		## take the positive part as the spline may be slightly negative
168		## at the ends
169	!	ret <- pmax(ret, 0)
170
171		## exponentiate them?
172	!	if (log) {
173	!	return(log(ret))
174		} else {
175	!	return(ret)
176		}
177		}
178		},
179		## --------------------
180	38x	linear = {
181		## now compute the spline
182	38x	linearSplineFun <- approxfun(
183	38x	x = extendedZVals,
184	38x	y = densVals,
185	38x	method = "linear",
186	38x	rule = 2
187	38x	) # return 0 outside the range.
188
189		## so the unnormalized z density approximation is
190	38x	function(z, log = FALSE) {
191	2238x	ret <- linearSplineFun(z)
192
193		## exponentiate them?
194	2238x	if (log) {
195	2200x	return(log(ret))
196		} else {
197	38x	return(ret)
198		}
199		}
200		},
201		## --------------------
202	38x	logspline = {
203		## add very small values to both ends of the log density values
204		## to smooth out the spline
205	!	logZero <- min(logDensVals) - 1e5
206	!	extendedLogDensVals <- c(
207	!	logZero,
208	!	logDensVals,
209	!	logZero
210		)
211
212		## now compute the spline
213	!	cubicSplineFun <- splinefun(
214	!	x = extendedZVals,
215	!	y = extendedLogDensVals,
216	!	method = "monoH.FC"
217		)
218
219		## so the unnormalized z density approximation is
220	!	function(z, log = FALSE) {
221		## set everything outside the range to zero
222		## (unfortunately this is not an option for "splinefun")
223	!	logRet <- ifelse(z > min(extendedZVals) & z < max(extendedZVals),
224	!	cubicSplineFun(z),
225	!	logZero
226		)
227
228		## exponentiate them?
229	!	if (log) {
230	!	return(logRet)
231		} else {
232	!	return(exp(logRet))
233		}
234		}
235		},
236		## --------------------
237	38x	normalspline = {
238		## now fit the cubic spline to the differences of the log density values.
239		## In order to get smooth decrease to zero, we add zeroes to the log difference vector
240		## at both ends
241	!	logDiffs <- c(
242	!	0,
243	!	logDensVals - normalDens(zVals, log = TRUE),
244	!	0
245		)
246
247	!	cubicSplineFun <- splinefun(
248	!	x = extendedZVals,
249	!	y = logDiffs,
250	!	method = "monoH.FC"
251		)
252
253		## optionally plot the spline of the log differences
254	!	if (plot) {
255	!	curve(cubicSplineFun,
256	!	from = min(extendedZVals), to = max(extendedZVals),
257	!	n = 301L,
258	!	main = "spline of log differences"
259		)
260	!	points(
261	!	x = extendedZVals,
262	!	y = logDiffs
263		)
264	!	abline(v = info$zMode)
265		}
266
267		## so the unnormalized z density approximation is
268	!	function(z, log = FALSE) {
269		## set everything outside the range to zero
270		## (unfortunately this is not an option for "splinefun")
271	!	splineVals <- ifelse(z > min(extendedZVals) & z < max(extendedZVals),
272	!	cubicSplineFun(z),
273	!	0
274		)
275
276		## the log values:
277	!	logRet <- splineVals + normalDens(z,
278	!	log = TRUE
279		)
280
281		## exponentiate them?
282	!	if (log) {
283	!	return(logRet)
284		} else {
285	!	return(exp(logRet))
286		}
287		}
288		},
289
290		## --------------------
291	38x	normal = {
292	!	normalDens
293		}
294		)
295
296		## decide which method to try first
297	38x	firstMethods <- match.arg(method, several.ok = TRUE)
298
299		## so what is the sequence this time?
300	38x	methodsSequence <- c(
301	38x	firstMethods,
302	38x	setdiff(
303	38x	c("linear", "spline", "logspline", "normalspline", "normal"),
304	38x	firstMethods
305		)
306		)
307
308		## then try the possible methods in this order
309	38x	for (m in methodsSequence) {
310		## get the unnormalized pdf
311	38x	unnormZdens <- eval(possibleMethods[[m]])
312
313		## first check that no infinite values occur!
314	38x	if (any(!is.finite(unnormZdens(extendedZGrid)))) {
315	!	warning(
316	!	"Infinite values for method ", m,
317	!	" in density approximation",
318	!	"going to the next method"
319		)
320
321		## if any is not finite, then go on to the next method
322	!	next
323		}
324
325		## then try to get the generator for that pdf
326	38x	generator <- try(getGenerator(
327	38x	method = m,
328	38x	unnormDensFun = unnormZdens,
329	38x	xVals = extendedZVals,
330	38x	unnormDensVals = densVals
331		))
332
333		## if this resulted in an error (computational or time-out),
334		## go on to the next method,
335		## else break
336	38x	if (!inherits(generator, "try-error")) {
337	38x	if (verbose) {
338	32x	cat("\nTaking the", m, "approximation method\n")
339		}
340	38x	break
341		}
342		}
343
344		## so the normalized log density is:
345	38x	logNormZdens <- function(z) {
346	2200x	unnormZdens(z, log = TRUE) - log(generator$normConst)
347		}
348
349		## optionally plot the final normalized approximation
350	38x	if (plot) {
351	!	plot(extendedZGrid,
352	!	exp(logNormZdens(extendedZGrid)),
353	!	type = "l",
354	!	main = "final approximation"
355		)
356	!	abline(v = info$zMode)
357		}
358
359		## return the list with the log density and the corresponding random number generator
360	38x	return(list(
361	38x	logDens = logNormZdens,
362	38x	gen = generator$generator
363		))
364		}
365
366
367		##' Internal helper function which gets the generator (and normalizing
368		##' constant)
369		##'
370		##' @param method the methods string
371		##' @param unnormDensFun the unnormalized density function
372		##' @param xVals the x values
373		##' @param unnormDensVals the unnormalized density values
374		##' @return a list with the elements \dQuote{generator} and \dQuote{normConst},
375		##' containing the generator function (with argument \code{n} for the number
376		##' of samples) and the normalizing constant of the density, respectively.
377		##'
378		##' @keywords internal
379		##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
380		getGenerator <- function(method,
381		unnormDensFun,
382		xVals,
383		unnormDensVals) {
384	38x	if (method == "linear") {
385		## we can build the generator ourselves.
386
387		## handy abbreviations
388	38x	nPoints <- length(xVals)
389	38x	z <- xVals
390	38x	y <- unnormDensVals
391
392		## first calculate the cdf points
393	38x	cdf <- numeric(nPoints)
394	38x	cdf[1L] <- 0
395	38x	for (i in 2:nPoints) {
396	4931x	cdf[i] <- cdf[i - 1] +
397	4931x	(y[i] + y[i - 1]) / 2 * (z[i] - z[i - 1])
398		}
399
400		## normalize
401	38x	normConst <- cdf[nPoints]
402	38x	cdf <- cdf / normConst
403	38x	y <- y / normConst
404
405		## and now the corresponding inverse cdf (quantile function)
406	38x	quantFun <- function(p) {
407		## check argument
408	61250x	stopifnot(
409	61250x	0 <= p,
410	61250x	1 >= p
411		)
412
413		## check the boundary cases
414	61250x	if (p == 0) {
415	!	return(z[1])
416		}
417	61250x	if (p == 1) {
418	!	return(z[nPoints])
419		}
420
421		## so now we are inside.
422
423		## find the right interval
424	61250x	i <- 2L # we can start at 2
425	61250x	while (p > cdf[i]) {
426	4303281x	i <- i + 1L
427		}
428		## so now cdf[i - 1] < p <= cdf[i]
429
430	61250x	slope <- (y[i] - y[i - 1L]) / (z[i] - z[i - 1L])
431	61250x	intercept <- y[i - 1L]
432	61250x	const <- cdf[i - 1] - p
433
434	61250x	solution <- (sqrt(intercept^2 - 2 * slope * const) - intercept) / slope
435
436	61250x	return(solution + z[i - 1L])
437		}
438
439		## vectorize that
440	38x	quantFunVec <- Vectorize(quantFun)
441
442		## so our generator function is
443	38x	gen <- function(n = 1) {
444	61250x	return(quantFunVec(runif(n = n)))
445		}
446
447		## so we return this list:
448	38x	return(list(
449	38x	generator = gen,
450	38x	normConst = normConst
451		))
452		} else {
453		## some Runuran generator is built.
454
455		## the creation is somewhat slow,
456		## but the generation from it is very fast.
457
458		## However, sometimes pinv.new seems to get stuck in an
459		## infinite loop. Therefore we limit the computation time
460		## for this call (only).
461	!	setTimeLimit(cpu = 40) # set time limit
462	!	on.exit(setTimeLimit(cpu = Inf)) # delete time limit after exiting this
463		# function. (either after normal exit or
464		# after an error)
465
466	!	unuranObject <- pinv.new(
467	!	pdf = unnormDensFun,
468	!	lb = min(xVals),
469	!	ub = max(xVals),
470	!	center = xVals[which.max(unnormDensVals)]
471		)
472
473		## get the normalizing constant
474		## (this is only possible before the object is packed!)
475	!	normConst <- unuran.details(unuranObject, show = FALSE, return.list = TRUE)$area.pdf
476
477		## "pack" the object so that it can be saved just as a normal R object.
478	!	unuran.packed(unuranObject) <- TRUE
479
480		## this function returns random variates from the pdf, where n is the number of variates to be
481		## produced
482	!	gen <- function(n = 1) {
483	!	return(ur(unuranObject, n = n))
484		}
485
486		## so we return this list:
487	!	return(list(
488	!	generator = gen,
489	!	normConst = normConst
490		))
491		}
492		}

1		#####################################################################################
2		## Author: Daniel Sabanés Bové [daniel . sabanesbove at* ifspm . uzh . ch]
3		## Project: BFPs for GLMs.
4		##
5		## Time-stamp: <[GPrior-classes.R] by DSB Mon 26/08/2013 11:34 (CEST)>
6		##
7		## Description:
8		## Hopefully a clean class system for the different priors on g.
9		##
10		## History:
11		## 15/03/2010 file creation in response to the redesign of the C++ side.
12		## 23/07/2010 we now only warn instead of producing an error when the integral
13		## is not equal to 1.
14		## 22/11/2012 add incomplete inverse gamma prior class
15		## 26/08/2013 link IncInvGammaGPrior from the virtual g-prior class
16		#####################################################################################
17
18		## ----------------------------------------------------------------------------
19
20		##' The virtual g-prior class
21		##'
22		##' This is the virtual g-prior class from which other g-prior classes derive.
23		##' The slots are:
24		##' \describe{
25		##' \item{logDens}{the prior log density}
26		##' }
27		##'
28		##' @seealso \code{\linkS4class{HypergPrior}}, \code{\linkS4class{InvGammaGPrior}},
29		##' \code{\linkS4class{IncInvGammaGPrior}}, \code{\linkS4class{CustomGPrior}}
30		##'
31		##' @name GPrior-class
32		##' @keywords classes internal
33		setClass(
34		Class = "GPrior",
35		representation =
36		representation(logDens = "function"),
37		contains = list("VIRTUAL"),
38		validity =
39		function(object) {
40		## check that the exp of the log density function
41		## is a valid density function
42
43		XMIN <- .Machine$double.xmin
44		EPS <- sqrt(.Machine$double.eps)
45
46		integrand <- function(g) exp(object@logDens(g))
47		integral <- integrate(
48		f = integrand,
49		lower = XMIN,
50		upper = Inf
51		)
52
53		if (integral$message != "OK") {
54		return(integral$message)
55		} else {
56		if (abs(integral$value - 1) > EPS) {
57		warning(
58		"density must be proper and normalized: (numerical) integral is ",
59		integral$value
60		)
61		}
62
63		return(TRUE)
64		}
65		}
66		)
67
68		## ----------------------------------------------------------------------------
69
70		##' The hyper-g prior class
71		##'
72		##' The slots are:
73		##' \describe{
74		##' \item{a}{the hyperparameter}
75		##' }
76		##'
77		##' @seealso the constructor \code{\link{HypergPrior}}
78		##'
79		##' @name HypergPrior-class
80		##' @keywords classes
81		##' @export
82		setClass(
83		Class = "HypergPrior",
84		representation =
85		representation(a = "numeric"),
86		contains = list("GPrior"),
87		validity =
88		function(object) {
89		if (object@a <= 3) {
90		return("the parameter a must be larger than 3 for proper posteriors")
91		} else {
92		return(TRUE)
93		}
94		}
95		)
96
97
98		##' Initialization method for the "HypergPrior" class
99		##'
100		##' @usage \S4method{initialize}{HypergPrior}(.Object, a, \dots)
101		##' @param .Object the \code{\linkS4class{HypergPrior}} we want to initialize
102		##' @param a the hyperparameter value
103		##' @param \dots unused
104		##' @return the initialized object
105		##'
106		##' @name HypergPrior-initialize
107		##' @aliases HypergPrior-initialize initialize,HypergPrior-method
108		##'
109		##' @keywords methods internal
110		##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
111		##'
112		##' @importFrom methods callNextMethod
113		##'
114		setMethod(
115		"initialize",
116		signature(.Object = "HypergPrior"),
117		function(.Object, a, ...) {
118	!	.Object@logDens <- function(g) {
119	!	return(log(a - 2) - log(2) - a / 2 * log1p(g))
120		}
121	!	callNextMethod(.Object, a = a, ...)
122		}
123		)
124
125
126		##' Constructor for the hyper-g prior class
127		##'
128		##' @param a the hyperparameter which must be larger than 3, and should not be larger than 4
129		##' in order not to favor too much shrinkage a priori (default: 4)
130		##' @return a new \code{\linkS4class{HypergPrior}} object
131		##'
132		##' @keywords classes
133		##' @export
134		HypergPrior <- function(a = 4) {
135	!	return(new("HypergPrior",
136	!	a = a
137		))
138		}
139
140
141		## ----------------------------------------------------------------------------
142
143		##' The inverse gamma g-prior class
144		##'
145		##' The slots are:
146		##' \describe{
147		##' \item{a}{the first hyperparameter}
148		##' \item{b}{the second hyperparameter}
149		##' }
150		##'
151		##' @seealso the constructor \code{\link{InvGammaGPrior}}
152		##'
153		##' @name InvGammaGPrior-class
154		##' @keywords classes
155		##' @export
156		setClass(
157		Class = "InvGammaGPrior",
158		representation =
159		representation(
160		a = "numeric",
161		b = "numeric"
162		),
163		contains = list("GPrior"),
164		validity =
165		function(object) {
166		if ((object@a <= 0) \|\| (object@b <= 0)) {
167		return("the parameters a and b must be positive")
168		} else {
169		return(TRUE)
170		}
171		}
172		)
173
174		##' Initialization method for the "InvGammaGPrior" class
175		##'
176		##' @usage \S4method{initialize}{InvGammaGPrior}(.Object, a, b, \dots)
177		##' @param .Object the \code{\linkS4class{InvGammaGPrior}} we want to initialize
178		##' @param a the first hyperparameter value
179		##' @param b the second hyperparameter value
180		##' @param \dots unused
181		##' @return the initialized object
182		##'
183		##' @name InvGammaGPrior-initialize
184		##' @aliases InvGammaGPrior-initialize initialize,InvGammaGPrior-method
185		##'
186		##' @keywords methods internal
187		##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
188		setMethod(
189		"initialize",
190		signature(.Object = "InvGammaGPrior"),
191		function(.Object, a, b, ...) {
192	4x	.Object@logDens <- function(g) {
193	76x	return(-(a + 1) * log(g) - b / g + a * log(b) - lgamma(a))
194		}
195	4x	callNextMethod(.Object, a = a, b = b, ...)
196		}
197		)
198
199		##' Constructor for the inverse gamma g-prior class
200		##'
201		##' @param a the first positive hyperparameter (default: 0.001)
202		##' @param b the second positive hyperparameter (default: 0.001)
203		##' @return a new \code{\linkS4class{InvGammaGPrior}} object
204		##'
205		##' @keywords classes
206		##' @export
207		InvGammaGPrior <- function(a = 0.001, b = 0.001) {
208	4x	return(new("InvGammaGPrior",
209	4x	a = a,
210	4x	b = b
211		))
212		}
213
214
215		## ----------------------------------------------------------------------------
216
217		##' The incomplete inverse gamma g-prior class
218		##'
219		##' The slots are:
220		##' \describe{
221		##' \item{a}{the first hyperparameter}
222		##' \item{b}{the second hyperparameter}
223		##' }
224		##'
225		##' @seealso the constructor \code{\link{IncInvGammaGPrior}}
226		##'
227		##' @name IncInvGammaGPrior-class
228		##' @keywords classes
229		##' @export
230		setClass(
231		Class = "IncInvGammaGPrior",
232		representation =
233		representation(
234		a = "numeric",
235		b = "numeric"
236		),
237		contains = list("GPrior"),
238		validity =
239		function(object) {
240		if (object@a <= 0) {
241		return("the parameter a must be positive")
242		} else if (object@b < 0) {
243		return("the parameter b must be non-negative")
244		} else {
245		return(TRUE)
246		}
247		}
248		)
249
250		##' Initialization method for the "IncInvGammaGPrior" class
251		##'
252		##' @usage \S4method{initialize}{IncInvGammaGPrior}(.Object, a, b, \dots)
253		##' @param .Object the \code{\linkS4class{IncInvGammaGPrior}} we want to initialize
254		##' @param a the first hyperparameter value
255		##' @param b the second hyperparameter value
256		##' @param \dots unused
257		##' @return the initialized object
258		##'
259		##' @name IncInvGammaGPrior-initialize
260		##' @aliases IncInvGammaGPrior-initialize initialize,IncInvGammaGPrior-method
261		##'
262		##' @keywords methods internal
263		##' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@ifspm.uzh.ch}
264		setMethod(
265		"initialize",
266		signature(.Object = "IncInvGammaGPrior"),
267		function(.Object, a, b, ...) {
268	!	.Object@logDens <- function(g) {
269	!	normConst <-
270	!	if (b > 0) {
271	!	a * log(b) - pgamma(b, a, log.p = TRUE) - lgamma(a)
272		} else {
273	!	log(a)
274		}
275
276	!	return(-(a + 1) * log1p(g) - b / (g + 1) + normConst)
277		}
278	!	callNextMethod(.Object, a = a, b = b, ...)
279		}
280		)
281
282		##' Constructor for the incomplete inverse gamma g-prior class
283		##'
284		##' @param a the first positive hyperparameter (default: 0.001)
285		##' @param b the second positive hyperparameter (default: 0.001)
286		##' @return a new \code{\linkS4class{IncInvGammaGPrior}} object
287		##'
288		##' @keywords classes
289		##' @export
290		IncInvGammaGPrior <- function(a = 0.001, b = 0.001) {
291	!	return(new("IncInvGammaGPrior",
292	!	a = a,
293	!	b = b
294		))
295		}
296
297
298		## ----------------------------------------------------------------------------
299
300		##' The custom g-prior class
301		##'
302		##' This class wraps around a custom log prior density for the covariance factor g.
303		##'
304		##' @seealso the constructor \code{\link{CustomGPrior}}
305		##'
306		##' @name CustomGPrior-class
307		##' @keywords classes
308		##' @export
309		setClass(
310		Class = "CustomGPrior",
311		contains = list("GPrior")
312		)
313
314
315		##' Constructor for the custom g-prior class
316		##'
317		##' @param logDens the log prior density function for g
318		##' @return a new \code{\linkS4class{CustomGPrior}} object
319		##'
320		##' @keywords classes
321		##' @export
322		CustomGPrior <- function(logDens) {
323	10x	return(new("CustomGPrior",
324	10x	logDens = logDens
325		))
326		}
327
328		## ----------------------------------------------------------------------------

1		#####################################################################################
2		## Author: Isaac Gravestock [isaac . gravestock at* uzh . ch]
3		## Project: Bayesian FPs for GLMs
4		##
5		## Description:
6		## Transform variables in formulas with fractional polynomials
7		##
8		## History:
9		## 14/07/2015 Copy from CoxTBFs project
10		#####################################################################################
11
12
13		##' Transform formula variables
14		##'
15		##' Simple function to apply the Box Tidwell transformation to a variables in a formula.
16		##' Variable is first shifted and scaled
17		##' NewVar = (Var+shift)/scale
18		##' then transformed and optionally centered.
19		##' Can be used in formulas as poly() is.
20		##'
21		##' @param var the variable to transform
22		##' @param powers one or more powers
23		##' @param scale value to scale the variable after shifting (default=1)
24		##' @param shift value to shift the variable by (default=0)
25		##' @param center center the variable when transforming.
26		##'
27		##' @return the transformed vector
28		##' @keywords utilities
29		##' @export
30		##'
31
32		fpTrans <- function(var, powers = 1, scale = 1, shift = 0, center = TRUE) {
33	!	varname <- deparse(substitute(var))
34
35	!	varm <- as.matrix(var)
36
37	!	newname <- if (shift != 0) {
38	!	paste("(", varname, "+", shift, ")", sep = "")
39		} else {
40	!	varname
41		}
42	!	if (scale != 1) newname <- paste(newname, "/", scale, sep = "")
43
44	!	colnames(varm) <- newname
45
46	!	if (scale == 0) stop("Attempting to scale (divide) by 0 in fpTrans")
47
48	!	varm <- (varm + shift) / scale
49
50		# out <- matrix(nrow=length(var), ncol=length(powers))
51
52	!	res <- getFpTransforms(vec = varm, powers = powers, center = center)
53	!	return(res)
54		}

1		#' Prediction methods for CoxTBF objects
2		#'
3		#' Predicts survival probabilities at given times. Compatible with predictSurvProb functions
4		#' required by \code{pec} package.
5		#'
6		#' @param object a model fitted with \code{\link{coxTBF}}
7		#' @param newdata a data frame with the same variables as the original data used to fit the object
8		#' @param times a vector of times to predict survival probability for
9		#' @param ... not used.
10		#'
11		#' @return A data frame of survival probabilities with rows for each row of newdata and columns for each time.
12		#' @export
13		#'
14		predict.TBFcox <- function(object, newdata = object$data, times, ...) {
15		# print("predictSurvProb TBF.Cox")
16		# print(paste("Train N =",nrow(attr(object$model.object,"data")$x),
17		# ". Predict N = ", nrow(newdata)))
18		# From sampleGlm.R from glmBfp packages by Sabanes Bove
19	1x	obj <- object$model.object
20	1x	config <- obj[[1]]$configuration
21		## get new data matrix
22	1x	tempX <- constructNewdataMatrix(
23	1x	object = obj,
24	1x	newdata = newdata
25		)
26
27		## copy old GlmBayesMfp object
28	1x	tempObj <- obj
29
30		## correct model matrix in tempMod to new data matrix
31	1x	attr(tempObj, "data") <-
32	1x	list(
33	1x	x = tempX,
34	1x	xCentered = scale(tempX, center = TRUE, scale = FALSE)
35		)
36
37		## so we can get the design matrix
38
39		# lets see what happens if we do this another way
40	1x	newDesignUC <- getDesignMatrix(
41	1x	modelConfig = config,
42	1x	object = tempObj,
43	1x	intercept = FALSE,
44	1x	center = FALSE
45		)
46
47
48	1x	oldDesignUC <- getDesignMatrix(
49	1x	modelConfig = config,
50	1x	object = obj,
51	1x	intercept = FALSE,
52	1x	center = FALSE
53		)
54
55	1x	oldMeans <- colMeans(oldDesignUC)
56
57	1x	for (i in seq_along(oldMeans)) {
58	4x	newDesignUC[, i] <- newDesignUC[, i] - oldMeans[i]
59		}
60
61		## so the linear predictor samples are
62	1x	linPredSamples <- newDesignUC %*% object$coefs
63
64
65	1x	return(object$survival(times, linPredSamples))
66		}
67
68
69
70
71
72		#' Prediction methods for CoxTBF objects with separate estimates
73		#'
74		#' Predicts survival probabilities at given times. Compatible with predictSurvProb functions
75		#' required by \code{pec} package. Predicts objects with fitted with \code{sep=TRUE}
76		#'
77		#' @param object a model fitted with \code{\link{coxTBF}}
78		#' @param newdata a dataframe with the same variables as the original data used to fit the object
79		#' @param times a vector of times to predict survival probability for
80		#' @param ... not used.
81		#'
82		#' @return A data frame of survival probabilities with rows for each row of newdata and columns for each time.
83		#' @export
84		#'
85		#'
86		predict.TBFcox.sep <- function(object, newdata, times, ...) {
87	1x	print("predictSurvProb TBF.Cox.sep")
88	1x	print(paste(
89	1x	"Train N =", nrow(attr(object$model.object, "data")$x),
90	1x	". Predict N = ", nrow(newdata)
91		))
92		# From sampleGlm.R from glmBfp packages by Sabanes Bove
93	1x	obj <- object$model.object
94	1x	config <- obj[[1]]$configuration
95		## get new data matrix
96	1x	tempX <- constructNewdataMatrix(
97	1x	object = obj,
98	1x	newdata = newdata
99		)
100
101		## copy old GlmBayesMfp object
102	1x	tempObj <- obj
103
104		## correct model matrix in tempMod to new data matrix
105	1x	attr(tempObj, "data") <-
106	1x	list(
107	1x	x = tempX,
108	1x	xCentered = scale(tempX, center = TRUE, scale = FALSE)
109		)
110
111		## so we can get the design matrix
112
113		# lets see what happens if we do this another way
114	1x	newDesignUC <- getDesignMatrix(
115	1x	modelConfig = config,
116	1x	object = tempObj,
117	1x	intercept = FALSE,
118	1x	center = FALSE
119		)
120
121
122	1x	oldDesignUC <- getDesignMatrix(
123	1x	modelConfig = config,
124	1x	object = obj,
125	1x	intercept = FALSE,
126	1x	center = FALSE
127		)
128
129	1x	oldMeans <- colMeans(oldDesignUC)
130
131	1x	for (i in seq_along(oldMeans)) {
132	1x	newDesignUC[, i] <- newDesignUC[, i] - oldMeans[i]
133		}
134
135		## so the linear predictor samples are
136	1x	linPredSamples <- lapply(object$coefs, function(coefs) newDesignUC %*% coefs)
137
138	1x	k <- length(linPredSamples)
139
140	1x	ret.survival <- lapply(1:k, function(i) object$survival[[i]](times, linPredSamples[[i]]))
141
142	1x	ret.surv2 <- matrix(0, nrow = nrow(as.data.frame(ret.survival[[1]])), ncol = length(times))
143	1x	for (i in 1:k) {
144	200x	ret.surv2 <- ret.surv2 + ret.survival[[i]] / k
145		}
146
147	1x	return(ret.surv2)
148		}
149
150
151
152
153		#' Prediction methods for CoxTBF objects for BMA models
154		#'
155		#' Predicts survival probabilities at given times. Compatible with predictSurvProb functions
156		#' required by \code{pec} package. Predicts BMA objects.
157		#'
158		#' @param object a model fitted with \code{\link{coxTBF}}
159		#' @param newdata a dataframe with the same variables as the original data used to fit the object
160		#' @param times a vector of times to predict survival probability for
161		#' @param ... not used.
162		#'
163		#' @return A data frame of survival probabilities with rows for each row of newdata and columns for each time.
164		#' @export
165		#'
166		#'
167		predict.TBFcox.BMA <- function(object, newdata, times, ...) {
168	1x	post <- object$probability / sum(object$probability)
169	1x	time <- object$time
170
171	1x	N <- nrow(newdata)
172	1x	k <- length(object$model.object)
173	1x	t <- length(times)
174
175	1x	preds <- matrix(0, nrow = t, ncol = N)
176	1x	Big.Matrix <- matrix(0, nrow = k, ncol = t)
177	1x	LP.Matrix <- matrix(0, nrow = N, ncol = k)
178	1x	W.Matrix <- diag(x = post)
179
180
181	1x	print(paste("Predict BMA", "N=", N, "k=", k, "t=", t))
182		# Populate (exp) LP.Matrix
183		# This can probably be made faster since I think some of the matrices are identical
184
185	1x	print("Making Model Matrices")
186	1x	for (i in seq_along(object$model.object)) {
187		# From sampleGlm.R from glmBfp packages by Sabanes Bove
188	1x	obj <- object$model.object[i]
189	1x	config <- obj[[1]]$configuration
190		## get new data matrix
191	1x	tempX <- constructNewdataMatrix(
192	1x	object = obj,
193	1x	newdata = newdata
194		)
195
196		## copy old GlmBayesMfp object
197	1x	tempObj <- obj
198
199		## correct model matrix in tempMod to new data matrix
200	1x	attr(tempObj, "data") <-
201	1x	list(
202	1x	x = tempX,
203	1x	xCentered = scale(tempX, center = TRUE, scale = FALSE)
204		)
205
206		## so we can get the design matrix
207
208		# lets see what happens if we do this another way
209	1x	newDesignUC <- getDesignMatrix(
210	1x	modelConfig = config,
211	1x	object = tempObj,
212	1x	intercept = FALSE,
213	1x	center = FALSE
214		)
215
216
217	1x	oldDesignUC <- getDesignMatrix(
218	1x	modelConfig = config,
219	1x	object = obj,
220	1x	intercept = FALSE,
221	1x	center = FALSE
222		)
223
224	1x	oldMeans <- colMeans(oldDesignUC)
225
226	1x	newDesignUC <- newDesignUC - rep(oldMeans, each = nrow(newDesignUC))
227
228		## so the linear predictor samples (after exp transform) are
229	1x	LP.Matrix[, i] <- exp(newDesignUC %*% object$coefs[[i]])
230		}
231
232	1x	print("Making Big Matrix")
233		# Populate Big.Matrix
234	1x	for (i in 1:t) {
235	2x	tm <- max((seq_along(time))[time <= times[i] + 1e-06])
236	2x	Big.Matrix[, i] <- object$survfit[, tm]
237	2x	if (times[i] > max(time) + 1e-06) {
238	!	Big.Matrix[, i] <- NA
239		}
240		}
241
242	1x	print("Making Predictions")
243		# for(i in 1:k){
244		# print(paste("p=",i,"of",k))
245		# preds <- preds + post[i]* outer(Big.Matrix[i,], LP.Matrix[,i], "^")
246		# }
247	1x	preds <- predBMAcpp(Big.Matrix, LP.Matrix, post)
248
249	1x	print("Finished Predictions")
250	1x	preds <- t(preds)
251	!	if (is.data.frame(preds)) colnames(preds) <- times
252	1x	return(preds)
253		}

1		#####################################################################################
2		## Author: Daniel Sabanés Bové [daniel . sabanesbove at* ifspm . uzh . ch]
3		## Project: Bayesian fractional polynomials
4		##
5		## Time-stamp: <[testCox.R] by DSB Mit 03/07/2013 22:58 (CEST)>
6		##
7		## Description:
8		## R code and interface to C++ code that could be used for the Cox model
9		## computations, for regression testing purposes.
10		##
11		## History:
12		## 29/11/2012 file creation
13		## 03/12/2012 make it internal
14		## 03/07/2013 add offsets
15		#####################################################################################
16
17		##' @include helpers.R
18		NULL
19
20
21		##' Test the Cox model computation for the TBF approach
22		##'
23		##' @param survTimes the survival times
24		##' @param censInd the logical censoring indicator (\code{TRUE} = observed,
25		##' \code{FALSE} = censored survival times)
26		##' @param offsets known component to be included in the linear predictor during
27		##' fitting. This must be a numeric vector of length equal to the number of
28		##' cases (if not provided, a vector of zeroes)
29		##' @param X the design matrix, without the intercept 1's!, with at least one
30		##' column
31		##' @param useCppCode use the C++ code? (default) otherwise the R-function
32		##' \code{\link{coxph}} is used
33		##' @return a list with the coefficient estimates (\code{betas}), the covariance
34		##' matrix estimate (\code{cov}) and the residual deviance (\code{deviance}).
35		##'
36		##' @keywords utilities internal
37		##' @importFrom survival coxph
38		##' @author Daniel Sabanes Bove
39		testCox <- function(survTimes,
40		censInd,
41		offsets = rep.int(0, length(survTimes)),
42		X,
43		useCppCode = FALSE) {
44		## checks
45	2x	stopifnot(
46	2x	is.numeric(survTimes),
47	2x	is.logical(censInd),
48	2x	is.matrix(X),
49	2x	identical(length(survTimes), length(censInd)),
50	2x	identical(length(survTimes), length(offsets)),
51	2x	identical(length(survTimes), nrow(X)),
52	2x	is.bool(useCppCode)
53		)
54
55		## summaries
56	2x	nObs <- nrow(X)
57	2x	nCovs <- ncol(X)
58
59		## check that we have at least one covariate
60		## (null model is not treated here)
61	2x	stopifnot(nCovs > 0)
62
63		## method for handling ties:
64	2x	method <- "efron"
65
66		## now do either simple R or go C++
67	2x	if (useCppCode) {
68		## sort according to survival times
69	1x	sorted <- order(survTimes)
70	1x	survTimes <- survTimes[sorted]
71	1x	censInd <- censInd[sorted]
72	1x	X <- X[sorted, ]
73
74		## go C++ for fitting the Cox model
75	1x	storage.mode(X) <- "double"
76	1x	tmp <- cpp_coxfit(
77	1x	as.double(survTimes),
78	1x	as.integer(censInd),
79	1x	as.double(offsets),
80	1x	X,
81	1x	ifelse(method == "efron", 1L, 0L)
82		)
83
84		## get results
85	1x	deviance <- -2 * (tmp$loglik[1] - tmp$loglik[2])
86	1x	covMat <- tmp$imat
87	1x	betas <- tmp$coef
88		} else {
89		## fit the Cox model
90	1x	tmp <- survival::coxph(Surv(survTimes, censInd) ~ X + offset(offsets), ties = method)
91
92		## get results
93	1x	deviance <- -2 * (tmp$loglik[1] - tmp$loglik[2])
94	1x	covMat <- tmp$var
95	1x	betas <- tmp$coefficients
96		}
97
98		## return the results
99	2x	return(list(
100	2x	betas = betas,
101	2x	cov = covMat,
102	2x	deviance = deviance
103		))
104		}

1		#####################################################################################
2		## Author: Daniel Sabanes Bove [daniel . sabanesbove at* ifspm . uzh . ch]
3		## Project: Bayesian FPs for GLMs.
4		##
5		## Time-stamp: <[inclusionProbs.R] by DSB Die 01/12/2009 13:21 (CET)>
6		##
7		## Description:
8		## Compute (model averaged) posterior inclusion probabilities for the uncertain
9		## variables (including FP variables) based on a GlmBayesMfp object.
10		##
11		## History:
12		## 01/12/2009 modify from the bfp package, and add roxygen tags.
13		#####################################################################################
14
15		##' Compute posterior inclusion probabilities based on GlmBayesMfp object
16		##'
17		##' Compute (model averaged) posterior inclusion probabilities for the uncertain
18		##' variables (including FP variables) based on a GlmBayesMfp object.
19		##'
20		##' @param GlmBayesMfpObject the GlmBayesMfp object
21		##' @param postProbs the vector of posterior model probabilities, defaults to
22		##' the normalized probabilities in \code{GlmBayesMfpObject}
23		##' @return the resulting inclusion probabilities vector
24		##'
25		##' @export
26		##' @keywords utilities
27		inclusionProbs <- function(GlmBayesMfpObject,
28		postProbs =
29		posteriors(GlmBayesMfpObject,
30		type = "normalized"
31		)) {
32	!	postProbs <- postProbs / sum(postProbs)
33	!	inds <- attr(GlmBayesMfpObject, "indices")
34	!	termNames <- attr(GlmBayesMfpObject, "termNames")
35
36	!	nams <- unlist(termNames[c("bfp", "uc")])
37	!	ret <- numeric(length(nams))
38	!	names(ret) <- nams
39
40	!	i <- 0
41
42	!	for (j in seq_along(inds$bfp)) {
43	!	i <- i + 1
44	!	present <- sapply(GlmBayesMfpObject, function(one) as.logical(length(one$configuration$powers[[j]])))
45	!	ret[i] <- sum(present * postProbs)
46		}
47
48	!	for (j in seq_along(inds$ucList)) {
49	!	i <- i + 1
50	!	present <- sapply(GlmBayesMfpObject, function(one) any(j == one$configuration$ucTerms))
51	!	ret[i] <- sum(present * postProbs)
52		}
53
54	!	return(ret)
55		}
56
57		## ****************************************************************************************************

1		#####################################################################################
2		## Author: Daniel Sabanes Bove [daniel . sabanesbove at* ifspm . uzh . ch]
3		## Project: Bayesian FPs
4		##
5		## Time-stamp: <[fpScale.R] by DSB Die 16/02/2010 13:12 (CET)>
6		##
7		## Description:
8		## Scale an FP term variable appropriately before model search using "fpScale".
9		##
10		## History:
11		## 04/07/2008 copy from thesis function collection.
12		## 18/11/2009 document with Roxygen
13		#####################################################################################
14
15		##' Shift and scale a covariate vector (if wished) to have positive and small numbers.
16		##'
17		##' This function is (almost exactly) copied from package \dQuote{mfp} to be consistent.
18		##'
19		##' @param x the covariate vector
20		##' @param scaling should shifting and scaling be performed (default)?
21		##'
22		##' @return list of \sQuote{shift} and \sQuote{scale} parameters appropriate for this
23		##' covariate vector.
24		##'
25		##' @keywords internal
26		fpScale <- function(x, scaling = TRUE) {
27	36x	scale <- 1
28	36x	shift <- 0
29
30		## check scaling argument
31	36x	stopifnot(is.bool(scaling))
32
33	36x	if (isTRUE(scaling)) {
34	36x	if (min(x) <= 0) {
35	6x	z <- diff(sort(x))
36	6x	shift <- min(z[z > 0]) - min(x)
37	6x	shift <- ceiling(shift * 10) / 10
38		}
39	36x	range <- mean(x + shift)
40	36x	scale <- 10^(sign(log10(range)) * round(abs(log10(range))))
41		}
42	36x	return(list(shift = shift, scale = scale))
43		}

1		/*
2		* bfgs.cpp
3		*
4		* Created on: 11.11.2009
5		* Author: daniel
6		*/
7
8		#include "bfgs.h"
9		#include "rcppExport.h"
10		#include "functionWraps.h"
11
12		using namespace Rcpp;
13
14		// ***************************************************************************************************//
15
16
17
18		// just an R interface to bfgs, for regression testing purposes.
19		// [[Rcpp::export]]
20		SEXP
21	152x	cpp_bfgs(SEXP r_startval, SEXP r_function, SEXP r_minx, SEXP r_maxx, SEXP r_precision, SEXP r_verbose )
22		{
23		// extract function and start value for minimization
24		// r_interface = CDR(r_interface);
25		// SEXP r_startval = CAR(r_interface);
26		//
27		// r_interface = CDR(r_interface);
28		// SEXP r_function = CAR(r_interface);
29		//
30		// // constraints on the argument
31		// r_interface = CDR(r_interface);
32		// SEXP r_minx = CAR(r_interface);
33		//
34		// r_interface = CDR(r_interface);
35		// SEXP r_maxx= CAR(r_interface);
36		//
37		// // and the settings
38		// r_interface = CDR(r_interface);
39		// SEXP r_precision = CAR(r_interface);
40		//
41		// r_interface = CDR(r_interface);
42		// SEXP r_verbose = CAR(r_interface);
43
44		// wrap the R function to a cached function
45	152x	RFunction fun(r_function);
46	152x	CachedFunction<RFunction> cachedFun(fun);
47
48		// then minimize (with constraints)
49		Bfgs<CachedFunction<RFunction> > bfgs(cachedFun,
50	304x	Rf_asLogical(r_verbose) == 1,
51		Rf_asReal(r_minx),
52		Rf_asReal(r_maxx),
53	152x	Rf_asReal(r_precision));
54
55	152x	double xMin = 0.0;
56	152x	double invHessMin = 0.0;
57
58	152x	int code = bfgs.minimize(Rf_asReal(r_startval),
59		xMin,
60	152x	invHessMin);
61
62		// pack results into R list
63	304x	return List::create(_["par"] = xMin,
64	304x	_["inv.hessian"] = invHessMin,
65	304x	_["evaluations"] = cachedFun.getCache().convert2list(),
66	608x	_["code"] = code);
67		}
68
69		// ***************************************************************************************************//
70
71		// End of file.
72

1		/*
2		* bfgs.h
3		*
4		* Created on: 13.11.2009
5		* Author: daniel
6		*/
7
8		#ifndef BFGS_H_
9		#define BFGS_H_
10
11		#include "functionWraps.h"
12
13		// ***************************************************************************************************//
14
15
16		// the main Bfgs class
17		template<class Fun>
18		class Bfgs {
19		public:
20		// setup the object
21		// - function is the function to be maximized (possibly constrained)
22		// - verbose: print progress on R screen?
23		// - lowerBound: lower bound on the function argument (default: -Inf)
24		// - upperBound: upper bound on the function argument (default: +Inf)
25		// - precision is precision parameter for the flatness at the maximum.
26		// - ftol and gtol are convergence parameters
27		// - stepsize is a parameter for the first ("crude") step of the algorithm
28	72x	Bfgs(Fun& function,
29		bool verbose=false,
30		double lowerBound=R_NegInf,
31		double upperBound=R_PosInf,
32		double precision=0.00001,
33		double ftol=0.0001,
34		double gtol=0.9,
35		double stepsize=3.0) :
36	72x	function(function),
37	72x	functionDeriv(function),
38	72x	verbose(verbose),
39	72x	lowerBound(lowerBound),
40	72x	upperBound(upperBound),
41	72x	precision(precision),
42	72x	ftol(ftol),
43	72x	gtol(gtol),
44	72x	stepsize(stepsize)
45		{
46		}
47
48		// minimize the function and compute the minimum and the inverted hessian at the minimum
49		int
50		minimize (double x0, double& xMin, double& invHessMin);
51
52		private:
53		// the function we want to maximize
54		Fun& function;
55
56		// and its numerical derivative
57		NumericDerivative<Fun> functionDeriv;
58
59		// echo progress?
60		const bool verbose;
61
62		// constraints on the function argument
63		const double lowerBound;
64		const double upperBound;
65
66		// settings
67		const double precision;
68		const double ftol;
69		const double gtol;
70		const double stepsize;
71
72
73		// internal linesearch class:
74		// (benefit is encapsulation and access to parent class members,
75		// here function, functionDeriv, and settings)
76		class Linesearch {
77		public:
78	414x	Linesearch(const Bfgs& bfgs, // reference to instance of enclosing class must be passed!!
79		// there is no automatic connection of nested class instances to the enclosing class instance.
80		double x,
81		double direction) :
82	414x	bfgs(bfgs),
83	414x	x(x),
84	414x	direction(direction),
85	414x	maxAlpha((direction < 0) ?
86	18x	((bfgs.lowerBound - x) / direction) :
87	396x	((bfgs.upperBound - x) / direction))
88		{
89		}
90
91		// do the linesearch for a given start point alpha1
92		double
93		operator()(double alpha1) const;
94
95		private:
96
97		// reference to the enclosing object
98		const Bfgs& bfgs;
99
100		// the point x and the direction of the search
101		const double x;
102		const double direction;
103
104		// the maximum alpha to be chosen: set by the constructor.
105		const double maxAlpha;
106
107		// objective and derivative of objective function are member functions
108		double
109	5004x	phi(double alpha) const
110		{
111	5004x	return bfgs.function(x + alpha * direction);
112		}
113
114		double
115	3366x	phi_(double alpha) const
116		{
117	3366x	return bfgs.functionDeriv(x + alpha * direction) * direction;
118		}
119
120		// other helper functions
121		bool
122	1116x	armijo(double alpha) const
123		{
124	1116x	return phi(alpha) <= (phi(0.0) + bfgs.ftol * alpha * phi_(0.0));
125		}
126
127		bool
128	522x	curvature(double alpha) const
129		{
130	522x	return fabs(phi_(alpha)) <= - bfgs.gtol * phi_(0.0);
131		}
132
133		double
134		interpolate(double x0,
135		double x1,
136		double f0,
137		double f1,
138		double g0) const;
139
140		double
141		zoom(double alpha_lo,
142		double alpha_hi) const;
143		};
144		};
145
146
147		// ***************************************************************************************************//
148
149		template <class Fun>
150		double
151	90x	Bfgs<Fun>::Linesearch::zoom(double alpha_lo,
152		double alpha_hi) const
153		{
154	684x	for (int i = 0; i < 30; ++i)
155		{
156	666x	double alpha = interpolate(alpha_lo, alpha_hi, phi(alpha_lo), phi(alpha_hi), phi_(alpha_lo));
157
158	666x	if ((! armijo(alpha)) \|\| (phi(alpha) >= phi(alpha_lo)))
159		{
160	540x	alpha_hi = alpha;
161		}
162		else
163		{
164	126x	if (curvature(alpha))
165		{
166	72x	return alpha;
167		}
168
169		// started going uphill?
170	54x	if (phi_(alpha) * (alpha_hi - alpha_lo) >= 0.0)
171		{
172	54x	alpha_hi = alpha_lo;
173		}
174	54x	alpha_lo = alpha;
175		}
176		}
177	18x	return 0.0; // not enough progress; give up.
178		}
179
180
181		// Implements the More-Thuente linesearch algorithm. The notation is taken from
182		// Nocedal and Wright (2006). This function returns an approximate solution to
183		//
184		// argmin_{alpha \in [0, maxAlpha]} phi(alpha).
185		//
186		// To avoid getting stuck in local minima, the algorithm attempts to find a
187		// point that satisfies the Wolfe conditions:
188		// - Armijo condition: the function has decreased enough. This is controlled
189		// by the "ftol" parameter.
190		// - curvature condition: the function has flattened out enough. This is
191		// controlled by the "gtol" parameter.
192		// (It will succeed at this, unless machine precision gets in the way.)
193		//
194		// The basic idea of the algorithm is:
195		// - do a crude search to find an interval that contains a local minimum
196		// that satisfies the Wolfe conditions.
197		// - do a bisection-like search on that interval, until a point is found
198		// that satisfies the Wolfe conditions.
199		//
200		// In particular, the algorithm doesn't attempt to find a local minimizer.
201		// It just tries to find a rough guess, which is much faster. The function
202		// that calls linesearch will do it many times. Since the Wolfe conditions
203		// are relative to the starting point of "linesearch", each subsequent call
204		// will give tighter approximations.
205		//
206		// The algorithm will terminate if the objective eventually starts decreasing,
207		// or a finite constraint on alpha is specified.
208		//
209		// Parameters:
210		// - phi : R -> R is the objective function to minimize.
211		// - phi_ : R -> R is the derivative of phi.
212		// - alpha1 is the starting point.
213		// - maxAlpha is an upper-bound constraint on alpha (can be Inf).
214		template <class Fun>
215		double
216	414x	Bfgs<Fun>::Linesearch::operator()(double alpha1) const
217		{
218		// initial check
219	414x	if (! (phi_(0) < 0.0))
220		{
221	!	Rf_warning("\nBfgs: phi_(0) >= 0.0 in linesearch algorithm");
222		}
223
224		// initialize old and new alpha
225	414x	double alpha_ = 0.0;
226	414x	double alpha = (alpha1 >= maxAlpha) ? maxAlpha / 2.0 : alpha1;
227
228		// iterate at most 100 times
229	468x	for (int i = 0; i < 100; ++i)
230		{
231	468x	if ((i > 0 && (phi(alpha) >= phi(alpha_))) \|\| (! armijo(alpha)))
232		{
233	72x	return zoom(alpha_, alpha);
234		}
235	396x	else if (curvature(alpha))
236		{
237	324x	return alpha;
238		}
239	72x	else if (phi_(alpha) >= 0.0)
240		{
241	18x	return zoom(alpha, alpha_);
242		}
243		else
244		{
245	54x	alpha_ = alpha;
246	54x	alpha = fmin((alpha + maxAlpha) / 2.0,
247	54x	alpha * bfgs.stepsize);
248		}
249		}
250
251		// return the last alpha if we did not break out of the loop beforehand.
252	!	return alpha;
253		}
254
255		// ***************************************************************************************************//
256
257		// the actual minimization function:
258		// returns
259		// -1 lost precision
260		// 0 ok
261		// 1 change not large enough
262		template <class Fun>
263		int
264	72x	Bfgs<Fun>::minimize(double x0, double& xMin, double& invHessMin)
265		{
266		// first check that start value fulfills constraints.
267	!	const bool insideBounds = (x0 >= lowerBound) && (x0 <= upperBound);
268	72x	if(! insideBounds)
269		{
270	!	Rf_error("Start value x0=%f for BFGS minimization not in admissible interval [%f, %f]", x0, lowerBound, upperBound);
271		}
272
273		// initialization
274	72x	xMin = x0;
275	72x	invHessMin = 1.0;
276
277	72x	int iter = 0;
278
279	72x	if(verbose)
280		{
281	72x	Rprintf("\nBfgs: Starting BFGS minimization ...");
282		}
283
284		// as long as the gradient is far enough away from zero
285	450x	while (fabs(functionDeriv(xMin)) > precision)
286		{
287	414x	++iter;
288
289		// possibly echo progress
290	414x	if (verbose)
291		{
292	414x	Rprintf("\nBfgs: now at iteration %d", iter);
293		}
294
295		// minimize in the direction of p
296	414x	double p = - invHessMin * functionDeriv(xMin);
297
298		// linesearch for factor alpha, starting from alpha = 1,
299		// with point x into direction p.
300
301		// first get maximum alpha
302
303
304	414x	double alpha = Linesearch(*this, xMin, p)(1.0);
305
306		// check result of linesearch:
307		// have we lost precision?
308	414x	if (alpha == 0.0)
309		{
310		// then warn
311	18x	if(verbose)
312		{
313	18x	Rprintf("\nBfgs: Lost precision in linesearch of iteration %d", iter);
314	18x	Rprintf("\nBfgs: Finished minimization.");
315		}
316
317		// and give back the current results and the error code
318	18x	return(-1);
319		}
320	396x	else if ((2.0 * fabs(alpha * p)) < precision)
321		{
322		// also break if the change is not large enough.
323	18x	if (verbose)
324		{
325	18x	Rprintf("\nBfgs: Change not large enough in iteration %d", iter);
326	18x	Rprintf("\nBfgs: Finished minimization.");
327		}
328
329	18x	return(1);
330		}
331
332		// compute the new x
333	378x	double x_ = xMin + alpha * p;
334
335		// inverted Hessian is numeric deriv of g at the new x_:
336	378x	invHessMin = (x_ - xMin) / (functionDeriv(x_) - functionDeriv(xMin));
337
338		// so now we are at x_
339	378x	xMin = x_;
340		}
341
342	36x	if(verbose)
343		{
344	36x	Rprintf("\nBfgs: Finished minimization.");
345		}
346
347		// return the convergence code
348	36x	return 0;
349		}
350
351		// ***************************************************************************************************//
352
353		// does quadratic interpolation to solve for the minimum on [x0, x1]
354		// f(x) = ax^2 + bx + c
355		//
356		// (1) f(x0) = f0 => f0 = a x0^2 + b x0 + c
357		// (2) f(x1) = f1 => f1 = a x1^2 + b x1 + c
358		// (3) f'(x0) = g0 => g0 = 2a x0 + b
359		//
360		// (1)-(2) f0 - f1 = a (x0^2 - x1^2) + b(x0 - x1)
361		// from (3): b = g0 - 2a x0
362		// from (1)-(2): f0 - f1 = a (x0^2 - x1^2) + (g0 - 2a x0)(x0 - x1)
363		// f0 - f1 - g0(x0 - x1) = a (x0^2 - x1^2) - 2a x0(x0 - x1)
364		// f0 - f1 - g0(x0 - x1) = a [(x0^2 - x1^2) - 2 x0(x0 - x1)]
365		// a = [f0 - f1 - g0(x0 - x1)] / [(x0^2 - x1^2) - 2 x0(x0 - x1)]
366		// = - [f0 - f1 - g0(x0 - x1)] / [(x0 - x1)^2]
367		//
368		// Then, f'(x) = 2ax + b. The "minimum" is at x = - b / (2a).
369		// (corrected here by DSB, it's not at x = -2a / b !!)
370		// of course, it is only the minimum if f''(x) = 2a > 0,
371		// which implies that f0 - f1 - g0(x0 - x1) < 0,
372		// or in other words g0 < (f0 - f1) / (x0 - x1) if x0 < x1.
373		template <class Fun>
374		double
375	666x	Bfgs<Fun>::Linesearch::interpolate(double x0,
376		double x1,
377		double f0,
378		double f1,
379		double g0) const
380		{
381	666x	double dx = x0 - x1;
382	666x	double a = - (f0 - f1 - g0 * dx) / (dx * dx);
383	666x	double b = g0 - 2.0 * a * x0;
384
385	666x	double x = - b / (2.0 * a);
386
387		// if it fails: return just the mid-point of [x0, x1]
388	666x	if ((R_finite(x) != 1) \|\| (x < fmin(x0, x1)) \|\| (x > fmax(x0, x1)))
389		{
390	54x	return (x0 + x1) / 2.0;
391		}
392		else
393		{
394	612x	return x;
395		}
396		}
397
398		// ***************************************************************************************************//
399
400
401		#endif /* BFGS_H_ */

1		/*
2		* functionWraps.h
3		*
4		* Created on: 06.11.2009
5		* Author: daniel
6		*/
7
8		#ifndef FUNCTIONWRAPS_H_
9		#define FUNCTIONWRAPS_H_
10
11		#include "rcppExport.h"
12		#include "types.h"
13
14		// ***************************************************************************************************//
15
16		// wrap a simple R function,
17		// taking a double argument and returning a double.
18		class RFunction
19		{
20		public:
21		// constructor
22	447x	RFunction(SEXP R_fun) :
23	447x	fun(R_fun)
24		{}
25
26		// // copy constructor
27		// RFunction(const RFunction& old);
28		//
29		// // destructor
30		// ~RFunction();
31		//
32		// // assignment operator
33		// RFunction& operator=(const RFunction& rhs);
34
35		// for use as a function (function object)
36		double
37		operator()(double x) const;
38
39		private:
40		Rcpp::Function fun;
41		};
42
43		// ***************************************************************************************************//
44
45		// now wrap an R function taking vectors of fixed length
46		class VectorRFunction
47		{
48		public:
49		// constructor
50		VectorRFunction(SEXP R_function, R_len_t argsize) :
51		fun(R_function),
52		argsize(argsize)
53		{}
54
55		// for use as a function (function object)
56		double
57		operator()(const double* vector) const;
58
59		private:
60		Rcpp::Function fun;
61		PosInt argsize;
62		};
63
64		// ***************************************************************************************************//
65
66		// simple function value cache
67		class Cache
68		{
69		public:
70		// save one pair of argument and function value
71		void
72		save(double arg, double val);
73
74		// extract the arguments
75		MyDoubleVector
76	429x	getArgs() const
77		{
78	429x	return args;
79		}
80
81		// extract the function values
82		MyDoubleVector
83	429x	getVals() const
84		{
85	429x	return vals;
86		}
87
88		// clear the cache
89		void
90		clear();
91
92		// look for an already computed function value
93		double
94		getValue(double arg) const;
95
96		// initialize from an R list
97		Cache(Rcpp::List& rcpp_list);
98
99		// default ctr is allowed as well
100	13524x	Cache(){};
101
102		// convert to an R list
103		Rcpp::List
104		convert2list() const;
105
106		private:
107		MyDoubleVector args;
108		MyDoubleVector vals;
109		};
110
111		// ***************************************************************************************************//
112
113		// cache all function results
114		template<class Fun>
115		class CachedFunction
116		{
117		public:
118		// constructor takes function object reference and stores it.
119	6873x	CachedFunction(Fun& function) :
120	6873x	function(function)
121		{
122		}
123
124		// return the cached values
125		Cache
126	6873x	getCache() const
127		{
128	6873x	return cache;
129		}
130
131		// for use as a function
132		double
133		operator()(double x);
134
135		private:
136		Fun& function;
137		Cache cache;
138		};
139
140		// ***************************************************************************************************//
141
142		// get derivative of a function
143		template<class Fun>
144		class NumericDerivative
145		{
146		public:
147		// save the function (object) reference
148	24x	NumericDerivative(Fun& function) :
149	24x	function(function)
150		{
151		}
152
153		// for use as a function
154		double
155		operator()(double x) const;
156
157		private:
158		Fun& function;
159		};
160
161		// ***************************************************************************************************//
162
163		// get more accurate derivative of a function
164		template<class Fun>
165		class AccurateNumericDerivative
166		{
167		public:
168		// save the function (object) reference
169	27396x	AccurateNumericDerivative(Fun& function,
170		double eps = 0.1) :
171	27396x	function(function),
172	27396x	h(eps),
173	27396x	ntab(10),
174	27396x	con(1.4),
175	27396x	con2(con * con),
176	27396x	big(DBL_MAX),
177	27396x	safe(2.0)
178		{
179	27396x	if(eps <= 0)
180		{
181	!	Rf_error("eps must be positive in AccurateNumericDerivative");
182		}
183		}
184
185		// for use as a function
186		double
187		operator()(double x) const;
188
189		private:
190		Fun& function;
191		const double h;
192
193		// sets maximum size of tableau
194		const int ntab;
195
196		// stepsize is decreased by factor con at each iteration
197		const double con;
198		const double con2;
199		const double big;
200
201		// return when error is safe worse than the best so far
202		const double safe;
203		};
204
205
206		// ***************************************************************************************************//
207
208		// get inverse second derivative of a function
209		template<class Fun>
210		class NumericInvHessian
211		{
212		public:
213		// save the function (object) reference and the epsilon parameter
214		NumericInvHessian(Fun& function,
215		double eps = EPS) :
216		function(function),
217		eps(eps)
218		{
219		}
220
221		// for use as a function
222		double
223		operator()(double x) const;
224
225		private:
226		Fun& function;
227		const double eps;
228		};
229
230		// ***************************************************************************************************//
231
232		// get more accurate inverse second derivative of a function
233		template<class Fun>
234		class AccurateNumericInvHessian
235		{
236		public:
237		// save the function (object) reference and the epsilon parameter
238	6849x	AccurateNumericInvHessian(Fun& function) :
239	6849x	function(function)
240		{
241		}
242
243		// for use as a function
244		double
245		operator()(double x) const;
246
247		private:
248		Fun& function;
249		};
250		// ***************************************************************************************************//
251
252		// for use as a function
253		template <class Fun>
254		double
255	1339074x	CachedFunction<Fun>::operator()(double x)
256		{
257	1339074x	double ret = cache.getValue(x);
258
259		// if not found in the old arguments
260	1339074x	if(R_IsNA(ret))
261		{
262		// we have to compute and save it.
263	869442x	ret = function(x);
264	869442x	cache.save(x, ret);
265		}
266
267		// finally return the value (either found or newly computed)
268	1339074x	return ret;
269		}
270
271		// ***************************************************************************************************//
272
273		// for use as a function
274		template <class Fun>
275		double
276	1662x	NumericDerivative<Fun>::operator()(double x) const
277		{
278		// if abs(x) is (almost) zero, take delta = eps; otherwise delta = x*eps.
279		// (important here: use of fabs instead of abs, which is an integer [!] version)
280	1662x	double delta = (fabs(x) == 0.0) ? EPS : x * EPS;
281
282		// return the estimated derivative at x:
283	1662x	return (function(x + delta) - function(x)) / delta;
284		}
285
286		// ***************************************************************************************************//
287
288		// for use as a function
289		template <class Fun>
290		double
291	177918x	AccurateNumericDerivative<Fun>::operator()(double x) const
292		{
293		// modified from
294		// http://www.koders.com/cpp/fid192DE24D3250B7B3632C6F54490A67268C992E28.aspx?s=Chebyshev
295		// (Numerical Recipes)
296
297	177918x	double hh = h;
298	177918x	double err = big;
299
300	355836x	std::vector<MyDoubleVector> a (ntab, MyDoubleVector (ntab, 0));
301
302	177918x	a[0][0] = (function(x + hh) - function(x - hh)) / (2.0 * hh);
303
304	177918x	double answer = a[0][0];
305
306	995964x	for (int i = 1; i < ntab; i++)
307		{
308		// Successive columns in the Neville tableau will go to smaller
309		// stepsizes and higher orders of extrapolation
310	995752x	hh /= con;
311
312		// Try new smaller stepsize:
313	995752x	a[0][i] = (function(x + hh) - function(x - hh)) / (2.0 * hh);
314
315	995752x	double fac = con2;
316
317		// Compute extrapolation of various orders, requiring no new function evaluations
318	4363800x	for (int j = 1; j <= i; j++)
319		{
320	3368048x	a[j][i] = (a[j-1][i] * fac - a[j-1][i-1]) / (fac - 1.0);
321
322	3368048x	fac = con2 * fac;
323
324	3368048x	double errt = fmax(fabs(a[j][i] - a[j-1][i]),
325	3368048x	fabs(a[j][i] - a[j-1][i-1]));
326
327		// The error strategy is to compare each new extrapolation to one order lower,
328		// both at the present stepsize and the previous one.
329
330		// If error is decreased, save the improved answer.
331	3368048x	if (errt <= err)
332		{
333	1378372x	err = errt;
334	1378372x	answer = a[j][i];
335		}
336		}
337
338		// If higher order is worse by a significant factor safe, then quit early.
339	995752x	if (fabs(a[i][i] - a[i-1][i-1]) >= safe * err)
340	177706x	break;
341		}
342
343	177918x	return answer;
344		}
345
346		// ***************************************************************************************************//
347
348		// for use as a function
349		template <class Fun>
350		double
351		NumericInvHessian<Fun>::operator()(double x) const
352		{
353
354		// if abs(x) is (almost) zero, take delta = eps; otherwise delta = x * eps.
355		// (important here: use of fabs instead of abs, which is an integer [!] version)
356		double delta = (fabs(x) == 0.0) ? eps : x * eps;
357		delta = fabs(delta);
358
359		// ensure that the difference between x and x + delta is exactly delta:
360		double volatile temp = x + delta;
361		delta = temp - x;
362
363		// return the estimated inverse hessian at x:
364		// (this is the analytical simplification of the centered differences formula, using the same
365		// delta for the first and the second numerical derivative)
366		// cf. Abramowitz/Stegun p. 884, formula 25.3.24.
367		double forward = function(x + delta) - function(x);
368		double backward = function(x) - function(x - delta);
369		double ret = (delta * delta) / (forward - backward);
370
371		return ret;
372		}
373
374		// ***************************************************************************************************//
375
376		// for use as a function
377		template <class Fun>
378		double
379	6849x	AccurateNumericInvHessian<Fun>::operator()(double x) const
380		{
381		// get the accurate derivative of the function
382	6849x	AccurateNumericDerivative<Fun> firstDerivative(function);
383
384		// and the accurate derivative of the first derivative
385	6849x	AccurateNumericDerivative<AccurateNumericDerivative<Fun> > secondDerivative(firstDerivative);
386
387		// so the result is
388	6849x	double ret = 1.0 / secondDerivative(x);
389
390		// return that
391	6849x	return ret;
392		}
393
394		// ***************************************************************************************************//
395
396		#endif /* FUNCTIONWRAPS_H_ */

1		// Modified by Isaac Gravestock (isaac.gravestock@uzh.ch)
2		//
3		// 13/07/2015: Update code to be compatible with CRAN
4		// Replace cout and exit
5		//
6
7		#include "combinatorics.h"
8		#include <iostream>
9		#include "types.h"
10		#include <cstdlib>
11		#include <Rcpp.h>
12
13		//using std::cout;
14		using namespace Rcpp;
15
16	1134x	void ksub_next ( int n, int k, IntVector& a, bool *more, int &m, int &m2)
17
18		//****************************************************************************80
19		//
20		// Purpose:
21		//
22		// KSUB_NEXT generates the subsets of size K from a set of size N.
23		//
24		// Modified:
25		//
26		// 29 May 2003
27		//
28		// Reference:
29		//
30		// Albert Nijenhuis, Herbert Wilf,
31		// Combinatorial Algorithms,
32		// Academic Press, 1978, second edition,
33		// ISBN 0-12-519260-6.
34		//
35		// Parameters:
36		//
37		// Input, int N, the size of the set from which subsets are drawn.
38		//
39		// Input, int K, the desired size of the subsets. K must
40		// be between 0 and N.
41		//
42		// Output, int A[K]. A[I] is the I-th element of the
43		// subset. Thus A[I] will be an integer between 1 and N.
44		// Note that the routine will return the values in A
45		// in sorted order: 1 <= A[0] < A[1] < ... < A[K-1] <= N
46		//
47		// Input/output, bool *MORE. Set MORE = FALSE before first call
48		// for a new sequence of subsets. It then is set and remains
49		// TRUE as long as the subset computed on this call is not the
50		// final one. When the final subset is computed, MORE is set to
51		// FALSE as a signal that the computation is done.
52		//
53		//
54		//
55		{
56		int j;
57
58	1134x	if ( k < 0 \|\| n < k )
59		{
60	!	Rcout << "\n";
61	!	Rcout << "KSUB_NEXT - Fatal error!\n";
62	!	Rcout << "N = " << n << "\n";
63	!	Rcout << "K = " << k << "\n";
64	!	Rcout << "but 0 <= K <= N is required!\n";
65		//exit ( 1 );
66	!	stop("Invalid parameters");
67		}
68
69	1134x	if ( !( *more ) )
70		{
71	108x	m2 = 0;
72	108x	m = k;
73		}
74		else
75		{
76	1026x	if ( m2 < n-m )
77		{
78	558x	m = 0;
79		}
80	1026x	m = m + 1;
81	1026x	m2 = a[k-m];
82		}
83
84	3294x	for ( j = 1; j <= m; j++ )
85		{
86	2160x	a[k+j-m-1] = m2 + j;
87		}
88
89	1134x	*more = ( a[0] != (n-k+1) );
90
91	1134x	return;
92		}
93
94		// ****************************************************************************************//
95
96	!	void comp_next ( int n, int k, IntVector& a, bool *more, int &h, int &t)
97
98		//****************************************************************************80
99		//
100		// Purpose:
101		//
102		// COMP_NEXT computes the compositions of the integer N into K parts.
103		//
104		// Discussion:
105		//
106		// The routine computes one composition on each call until there are no more.
107		// For instance, one composition of 6 into 3 parts is
108		// 3+2+1, another would be 6+0+0.
109		//
110		// Example:
111		//
112		// The 28 compositions of 6 into three parts are:
113		//
114		// 6 0 0, 5 1 0, 5 0 1, 4 2 0, 4 1 1, 4 0 2,
115		// 3 3 0, 3 2 1, 3 1 2, 3 0 3, 2 4 0, 2 3 1,
116		// 2 2 2, 2 1 3, 2 0 4, 1 5 0, 1 4 1, 1 3 2,
117		// 1 2 3, 1 1 4, 1 0 5, 0 6 0, 0 5 1, 0 4 2,
118		// 0 3 3, 0 2 4, 0 1 5, 0 0 6.
119		//
120		// Modified:
121		//
122		// 28 May 2003
123		//
124		// Author:
125		//
126		// Albert Nijenhuis, Herbert Wilf,
127		//
128		// C++ translation by John Burkardt.
129		//
130		// Reference:
131		//
132		// Albert Nijenhuis, Herbert Wilf,
133		// Combinatorial Algorithms,
134		// Academic Press, 1978, second edition,
135		// ISBN 0-12-519260-6.
136		//
137		// Parameters:
138		//
139		// Input, int N, the integer whose compositions are desired.
140		//
141		// Input, int K, the number of parts in the composition.
142		//
143		// Input/output, int A[K], the parts of the composition.
144		//
145		// Input/output, bool *MORE.
146		// Set MORE = FALSE on first call. It will be reset to TRUE on return
147		// with a new composition. Each new call returns another composition until
148		// MORE is set to FALSE when the last composition has been computed
149		// and returned.
150		//
151		{
152
153		int i;
154
155	!	if ( ! ( *more ) )
156		{
157	!	t = n;
158	!	h = 0;
159	!	a[0] = n;
160	!	for ( i = 1; i < k; i++ )
161		{
162	!	a[i] = 0;
163		}
164		}
165		else
166		{
167	!	if ( 1 < t )
168		{
169	!	h = 0;
170		}
171
172	!	h = h + 1;
173	!	t = a[h-1];
174	!	a[h-1] = 0;
175	!	a[0] = t - 1;
176	!	a[h] = a[h] + 1;
177
178		}
179
180	!	*more = ( a[k-1] != n );
181
182	!	return;
183		}

1		/*
2		* coxfit.h
3		*
4		* Created on: 03.12.2012
5		* Author: daniel
6		*/
7
8		#ifndef COXFIT_H_
9		#define COXFIT_H_
10
11		#include "types.h"
12
13		// Dynamic_2d_array class by David Maisonave (609-345-1007) (www.axter.com)
14		// Description:
15		// The dynamic array class listed below is more efficient then other
16		// similar classes that use temporary objects as return types, or use
17		// an std::vector as a return type.
18		//
19		// It's also more compatible with a C style 2D array, in that the
20		// array is in one continuous memory block. This makes it possible
21		// to pass this array object to a C Function that has a C-Style
22		// 2D array for a parameter.
23		// Example usage:
24		/*
25
26		Dynamic_2d_array<int> MyIntArray(12, 34);
27		MyIntArray[0][1] = 123;
28		cout << MyIntArray[0][1] << endl;
29
30		*/
31
32		template < class T >
33		class Dynamic_2d_array
34		{
35		public:
36		// constructor
37	17760x	Dynamic_2d_array(int row, int col) :
38	17760x	m_row(row),
39	17760x	m_col(col),
40	!	m_data((row!=0 && col!=0) ? new T[row*col] : NULL)
41		{}
42
43		// copy ctr
44		Dynamic_2d_array(const Dynamic_2d_array& src) :
45		m_row(src.m_row),
46		m_col(src.m_col),
47		m_data((src.m_row!=0 && src.m_col!=0) ? new T[src.m_row*src.m_col] : NULL)
48		{
49		for(int r=0; r<m_row; ++r)
50		for(int c=0; c<m_col; ++c)
51		(*this)[r][c] = src[r][c];
52		}
53
54		// destructor
55	17760x	~Dynamic_2d_array()
56		{
57	17760x	delete[] m_data;
58		}
59
60		// non-const access
61	187508584x	inline T* operator[](int i)
62		{
63	187508584x	return (m_data + (m_col*i));
64		}
65
66		// const access
67	367984x	inline T const*const operator[](int i) const
68		{
69	367984x	return (m_data + (m_col*i));
70		}
71
72		private:
73		const int m_row;
74		const int m_col;
75		T* m_data;
76		};
77
78		// Note that the class Dynamic_2d_array automatically allocates and
79		// deallocates the memory.
80		typedef Dynamic_2d_array<long> LongMatrix;
81		typedef Dynamic_2d_array<double> DoubleMatrix;
82		typedef Dynamic_2d_array<int> IntMatrix;
83
84		// **************************************************************************************
85
86
87		struct CoxfitResults
88		{
89		// constructor:
90	5920x	CoxfitResults(const int nCovs) :
91	5920x	coefs(nCovs),
92	5920x	imat(nCovs, nCovs),
93	5920x	u(nCovs),
94	5920x	loglik(2),
95	5920x	flag(0)
96		{
97		// fill with initial values for the null model:
98	5920x	coefs.fill(0.0);
99		}
100
101
102		// the coefficient vector
103		AVector coefs;
104
105		// the covariance matrix estimate
106		AMatrix imat;
107
108		// the score vector
109		AVector u;
110
111		// the log likelihoods of the initial coef vector and
112		// the final one
113		MyDoubleVector loglik;
114
115		// convergence flag
116		int flag;
117		};
118
119
120		// **************************************************************************************
121
122
123		// The class which does the Cox model fitting
124		class Coxfit {
125
126		public:
127
128		// ctr
129	5920x	Coxfit(const AVector& survTimes,
130		const IntVector& censInd,
131		const AMatrix& X,
132		const AVector& weights,
133		const AVector& offsets,
134		const int method,
135		double eps = 1e-09,
136		double tolerChol = pow(DBL_EPSILON, 0.75),
137		int iterMax = 40,
138	5920x	double tolerInf = 1e-05) :
139	5920x	survTimes(survTimes),
140	5920x	censInd(censInd),
141	5920x	X(X),
142	5920x	weights(weights),
143	5920x	offsets(offsets),
144	5920x	method(method),
145	5920x	nObs(survTimes.size()),
146	5920x	nCovs(X.n_cols),
147	5920x	strata(nObs, 0),
148	5920x	imat(nCovs, nCovs),
149	5920x	results(nCovs),
150	5920x	eps(eps),
151	5920x	tolerChol(tolerChol),
152	5920x	iterMax(iterMax),
153	5920x	tolerInf(tolerInf)
154		{}
155
156		// getter for results
157		CoxfitResults
158		finalizeAndGetResults();
159
160		// check results
161		void
162		checkResults() const;
163
164		// the fit function, returns the number of
165		// required iterations
166		int
167		fit();
168
169		// compute the residual deviance of this model
170		double
171		computeResidualDeviance();
172
173		private:
174
175		// inputs
176		AVector survTimes;
177		IntVector censInd;
178		AMatrix X;
179		AVector weights;
180		AVector offsets;
181		const int method;
182
183		const int nObs;
184		const int nCovs;
185
186		IntVector strata;
187
188		// temporary storage
189		DoubleMatrix imat;
190
191		// outputs
192		CoxfitResults results;
193
194		// numerical options
195		const double eps;
196		const double tolerChol;
197		const int iterMax;
198		const double tolerInf;
199		};
200
201		#endif /* COXFIT_H_ */

1		#ifndef DATASTRUCTURE_H_
2		#define DATASTRUCTURE_H_
3
4		#include <set>
5		#include <map>
6		#include <vector>
7		#include <iterator>
8		#include <numeric>
9		#include <string>
10
11		#include "rcppExport.h"
12		#include "types.h"
13		#include "functionWraps.h"
14		#include "fpUcHandling.h"
15		#include "links.h"
16		#include "distributions.h"
17		#include "gpriors.h"
18
19
20		// ***************************************************************************************************//
21
22		struct SafeSum
23		{
24		LongDoubleVector vals;
25
26		void
27		add(const long double &val);
28
29		// compute the sum of the elements using accurate algorithm
30		long double
31		sum();
32
33		// compute the log of the sum of the exp of the elements using accurate algorithm,
34		// and avoiding infinite contributions.
35		long double
36		logSumExp();
37
38		// compute the sum of the elements using very simple algorithm
39		long double
40		simpleSum();
41		};
42
43		// ***************************************************************************************************//
44
45		struct IndexSafeSum
46		{
47		// the model index collection
48		IndSet indices;
49
50		// add a model index i to the collection indices
51		void
52		add(const Ind& i);
53
54		// taking the safe sum object s of log posteriors, and the associated log normalizing
55		// constant logNormConst,
56		// compute the sum \sum_i in indices exp{s_i - logNormConst}.
57		long double
58		sumNormalizedExp(const SafeSum& s, long double logNormConst) const;
59		};
60
61		// ***************************************************************************************************//
62
63		// 21/11/2012: add tbf option
64
65		// bookkeeping, shall later be used by glm and hyper-g!
66		struct Book
67		{
68		PosLargeInt modelCounter;
69		PosLargeInt chainlength;
70		PosLargeInt nanCounter;
71
72		SafeSum modelLogPosteriors;
73		//IndexSafeSum *covGroupWisePosteriors; // for computation of covariate inclusion probs: array (bfp, uc)
74		std::vector<IndexSafeSum> covGroupWisePosteriors; // for computation of covariate inclusion probs: array (bfp, uc)
75
76		const bool tbf;
77		const bool doGlm;
78		const bool empiricalBayes;
79		const bool useFixedg;
80		const bool useFixedc;
81		const bool doSampling;
82		const bool verbose;
83		const std::string modelPrior;
84
85		const PosInt nModels;
86		const PosInt nCache;
87
88		const double largeVariance;
89		const bool useBfgs;
90		const bool debug;
91
92		const bool higherOrderCorrection;
93
94		// constructor which checks the chainlength
95		Book(bool tbf,
96		bool doGlm,
97		bool empiricalBayes,
98		bool useFixedg,
99		bool useFixedc,
100		double cl,
101		bool doSampling,
102		bool verbose,
103		std::string modelPrior,
104		PosInt nModels,
105		PosInt nCache,
106		double largeVariance,
107		bool useBfgs,
108		bool debug,
109		bool higherOrderCorrection);
110
111		};
112
113		// ***************************************************************************************************//
114
115		// data structure: model information for general models.
116		// keep in mind that contents must be assignable.
117		struct ModelInfo
118		{
119		// most important:
120		double logMargLik;
121		double logPrior;
122
123		// just the sum of logMargLik and logPrior.
124		// But we need it often, so save it here (the ctr computes it).
125		double logPost;
126
127		// only needed for MCMC:
128		PosLargeInt hits;
129
130		// simple constructor
131	9381x	ModelInfo(double logMargLik, double logPrior, PosLargeInt hits = 0) :
132	9381x	logMargLik(logMargLik), logPrior(logPrior), logPost(logMargLik + logPrior), hits(hits)
133		{
134		}
135
136		// compare two model infos bei their posterior probability:
137		// the model info with the lower one is lower.
138		bool
139	1956x	operator<(const ModelInfo& m) const
140		{
141	1956x	return logPost < m.logPost;
142		}
143		};
144
145		// ***************************************************************************************************//
146
147		//// specialization for normal model with hyper-g prior
148		//struct NormalModelInfo : public ModelInfo
149		//{
150		// // additional to ModelInfo:
151		//
152		// // posterior expected factor g given this model
153		// double postExpectedg;
154		//
155		// // posterior expected shrinkage factor g/(1+g) given this model
156		// double postExpectedShrinkage;
157		//
158		// // coefficient of determination for this model
159		// double R2;
160		//
161		// // constructor
162		// NormalModelInfo(double logMargLik,
163		// double logPrior,
164		// double postExpectedg,
165		// double postExpectedShrinkage,
166		// double R2,
167		// PosLargeInt hits) :
168		// ModelInfo(logMargLik, logPrior, hits),
169		// postExpectedg(postExpectedg),
170		// postExpectedShrinkage(postExpectedShrinkage),
171		// R2(R2)
172		// {
173		// }
174		//};
175
176		// ***************************************************************************************************//
177
178		// specialization for GLM model
179		struct GlmModelInfo : public ModelInfo
180		{
181	9258x	GlmModelInfo(double logMargLik,
182		double logPrior,
183		const Cache& cache,
184		double zMode,
185		double zVar,
186		double laplaceApprox,
187	9258x	double residualDeviance) :
188		ModelInfo(logMargLik,
189		logPrior),
190	9258x	negLogUnnormZDensities(cache),
191	9258x	zMode(zMode),
192	9258x	zVar(zVar),
193	9258x	laplaceApprox(laplaceApprox),
194	9258x	residualDeviance(residualDeviance)
195		{
196		}
197
198		// cache of negative log unnormalized posterior density of z evaluations:
199
200		// the z values
201		Cache negLogUnnormZDensities;
202
203		// moment estimates:
204
205		// mode of the z posterior (z*)
206		double zMode;
207
208		// and associated estimated variance (sigma*^2)
209		double zVar;
210
211		// here is the resulting Laplace approximation of the log marginal likelihood
212		double laplaceApprox;
213
214		// this is only filled in the TBF case
215		double residualDeviance;
216
217		// convert to R list
218		Rcpp::List
219		convert2list(long double logNormConst,
220		const Book& bookkeep) const;
221
222		// conversion of R list to modelInfo:
223		// Cache and hits are not filled!
224		explicit
225	82x	GlmModelInfo(Rcpp::List rcpp_information) :
226		ModelInfo(rcpp_information["logMargLik"],
227		rcpp_information["logPrior"],
228		NA_INTEGER),
229	82x	zMode(rcpp_information["zMode"]),
230	82x	zVar(rcpp_information["zVar"]),
231	82x	laplaceApprox(rcpp_information["laplaceApprox"]),
232	164x	residualDeviance(rcpp_information["residualDeviance"])
233		{
234		}
235		};
236
237		// ***************************************************************************************************//
238
239		// model parameter object: must have a strict weak ordering
240		struct ModelPar
241		{
242		PowersVector fpPars; // vector of multisets
243
244		// not needed: just use fpPars.size()
245		// PosInt nFps; // length of vector
246
247		PosInt fpSize; // number of fp powers
248		IntSet ucPars; // set of group indices, starting from 1 (!)
249		IntSet fixPars; // set of group indices, starting from 1 (!)
250
251		// not needed: just use ucPars.size()
252		// PosInt ucSize; // number of uc Groups included
253
254		// start with an empty (null) model:
255	120x	ModelPar(PosInt nFps) :
256	120x	fpPars(nFps), fpSize(0), ucPars(), fixPars()
257		{
258		}
259
260		// comparison of configurations
261		bool
262		operator<(const ModelPar& m) const;
263
264		// return a textual description of this model configuration
265		std::string
266		print(const FpInfo& fpInfo) const;
267
268		// return the size of the model (excluding the intercept)
269		PosInt
270		size(const UcInfo& ucInfo, const FixInfo& fixInfo) const;
271
272		// convert to R list
273		Rcpp::List
274		convert2list(const FpInfo& currFp) const;
275
276		// convert R list to ModelPar
277		ModelPar(Rcpp::List rcpp_configuration,
278		const FpInfo& fpInfo);
279
280		// compute set of free uc group indices in a model configuration
281		IntSet
282		getFreeUcs(const PosIntVector& ucSizes,
283		const PosInt& currDim,
284		const PosInt& maxDim) const;
285
286		// compute set of free cov indices in a model configuration
287		PosIntSet
288		getFreeCovs(const FpInfo& currFp,
289		const IntSet& freeUcs,
290		const PosInt& currDim,
291		const PosInt& maxDim) const;
292
293		// determine set of present cov indices
294		PosIntSet
295		getPresentCovs() const;
296
297		// push back index into covGroupWisePosteriors-Array
298		void
299		pushInclusionProbs(const FpInfo& fpInfo,
300		const UcInfo& ucInfo,
301		Book& bookkeep) const;
302		};
303
304		// ***************************************************************************************************//
305
306
307		// first only for Glms. Possibly extended with template class for ModelInfo to NormalModelInfo.
308		struct Model
309		{
310		ModelPar par;
311		GlmModelInfo info;
312
313		// initialize
314	840x	Model(const ModelPar& p, const GlmModelInfo& i) :
315	840x	par(p), info(i)
316		{
317		}
318
319		// fully forward the comparison to the model parameter and info class.
320		// we need to include the par comparison because sometimes
321		// really the info is identical...
322		bool
323	3536x	operator<(const Model& m) const // less
324		{
325	3536x	if(info < m.info)
326	1856x	return true;
327	1680x	else if(m.info < info)
328	1392x	return false;
329		else
330	288x	return par < m.par;
331		}
332
333		// model to list
334		Rcpp::List
335		convert2list(const FpInfo& currFp,
336		long double logNormConst,
337		const Book& bookkeep) const;
338		};
339
340
341		// ***************************************************************************************************//
342
343
344		class GaussHermite {
345		public:
346		// compute nodes and log weights for given mode and sd of target unnormalized density
347		void
348		getNodesAndLogWeights(double mode, double var,
349		MyDoubleVector& nodes, MyDoubleVector& logWeights) const; // output
350
351		// constructor
352	120x	GaussHermite(Rcpp::List rcpp_gaussHermite) :
353	120x	tVec(Rcpp::as<MyDoubleVector>(rcpp_gaussHermite["nodes"])),
354	120x	wVec(Rcpp::as<MyDoubleVector>(rcpp_gaussHermite["weights"]))
355		{
356		}
357
358		private:
359		const MyDoubleVector tVec; // nodes
360		const MyDoubleVector wVec; // weights (not log!)
361		};
362
363
364		// ***************************************************************************************************//
365
366
367
368		struct GlmModelConfig
369		{
370		// vector of dispersions (phi / weights)
371		const AVector dispersions;
372
373		// vector of weights
374		const AVector weights;
375
376		// vector of starting values for the linear predictor
377		// constant, because for each model we will initially start from that.
378		const AVector linPredStart;
379
380		// the vector of offsets
381		const AVector offsets;
382
383		// log marg lik of the the null model
384		const double nullModelLogMargLik;
385
386		// deviance of the the null model
387		const double nullModelDeviance;
388
389		// fixed value of g
390		const double fixedg;
391
392		// the g-prior information
393		const GPrior* gPrior;
394
395		// the link information
396		const Link* link;
397
398		// the distribution information
399		const Distribution* distribution;
400
401		// the constant factor deriving from the link and the distribution,
402		// which we need for the generalized g-prior
403		double cfactor;
404
405		// save also the names of link and distribution
406		const std::string familyString;
407		const std::string linkString;
408
409		// does this model use the canonical link?
410		const bool canonicalLink;
411
412		// should we use the empirical g prior which uses
413		// the information matrix ( J(B)^-1 ) for the covariance instead of (X'X)^-1
414		const bool empiricalgPrior;
415
416		// constructor
417		GlmModelConfig(Rcpp::List& rcpp_family,
418		double nullModelLogMargLik,
419		double nullModelDeviance,
420		double fixedg,
421		Rcpp::S4& rcpp_gPrior,
422		const AVector& responses,
423		bool debug,
424		bool useFixedc,
425		double empiricalMean,
426		bool empiricalgPrior);
427
428		// destructor
429	171x	~GlmModelConfig()
430		{
431	171x	delete gPrior;
432	171x	delete link;
433	171x	delete distribution;
434		}
435		};
436
437		// ***************************************************************************************************//
438
439
440		struct DataValues
441		{
442		AMatrix design;
443		AMatrix centeredDesign;
444
445		AVector response;
446		double sumOfSquaresTotal;
447
448		IntVector censInd;
449
450		int nObs;
451
452		AVector onesVector;
453
454		PosLargeInt totalNumber; // cardinality of model space
455
456		const IntSet fixedCols;
457
458		DataValues(const AMatrix &x,
459		const AMatrix &xcentered,
460		const AVector &y,
461		const IntVector &censInd,
462		const double &totalNum,
463		const IntSet& fixedCols);
464		};
465
466
467		// ***************************************************************************************************//
468
469		// first only for GLM models:
470		// the model cache class.
471
472		// Caches the best models in a map of a given maximum size, and also stores the
473		// (unnormalized) log posterior probabilities in an ordered set, pointing to the models in the map.
474		class ModelCache {
475		public:
476
477
478		// create a new ModelCache with given maximum size.
479	112x	ModelCache(int maxSize) :
480	112x	maxSize(maxSize),
481	112x	modelMap(),
482	112x	modelIterSet()
483		{
484		}
485
486		// check if max size was reached
487		bool
488	4554x	isFull() const
489		{
490	4554x	return modelMap.size() == maxSize;
491		}
492
493		// return size of cache
494		int
495	144x	size() const
496		{
497	144x	return modelMap.size();
498		}
499
500		// insert model parameter and belonging model info into the cache.
501		// returns false if not inserted (e.g. because the par was
502		// already inside, or the model was not good enough)
503		bool
504		insert(const ModelPar& par, const GlmModelInfo& info);
505
506		// search for the model info of a model config in the map,
507		// and return an information with NA for log marg lik if not found
508		GlmModelInfo
509		getModelInfo(const ModelPar& par) const;
510
511		// increment the sampling frequency for a model configuration
512		// (of course, if this config is not cached nothing is done!)
513		void
514		incrementFrequency(const ModelPar& par);
515
516		// compute the log normalising constant from all cached models
517		long double
518		getLogNormConstant() const;
519
520		// compute the inclusion probabilities from all cached models,
521		// taking the log normalising constant and the total number of FPs / UC groups
522		MyDoubleVector
523		getInclusionProbs(long double logNormConstant, PosInt nFps, PosInt nUcs) const;
524
525		// convert the best nModels from the cache into an R list
526		Rcpp::List
527		getListOfBestModels(const FpInfo& fpInfo,
528		long double logNormConst,
529		const Book& bookkeep) const;
530
531
532		private:
533		// the map type
534		typedef std::map<ModelPar, GlmModelInfo> MapType;
535
536		// define comparison function for iterators
537		struct Compare_map_iterators
538		{
539		bool
540	38250x	operator()(const MapType::iterator& first, const MapType::iterator& second) const
541		{
542	38250x	return (first->second.logPost) < (second->second.logPost);
543		}
544		};
545
546		// the set type of ordered map iterators
547		typedef std::set<MapType::iterator, Compare_map_iterators> SetType;
548
549		// and finally the data members
550		const MapType::size_type maxSize;
551		MapType modelMap;
552		SetType modelIterSet;
553		};
554
555		// ***************************************************************************************************//
556
557		// all information needed in mcmc function
558		struct ModelMcmc
559		{
560		// initialize with the null model only.
561	112x	ModelMcmc(const FpInfo& fpInfo,
562		const UcInfo& ucInfo,
563		PosInt maxDim,
564	112x	double logMargLikNullModel) :
565	112x	modPar(fpInfo.nFps),
566	112x	dim(1),
567	112x	freeUcs(modPar.getFreeUcs(ucInfo.ucSizes, dim, maxDim)),
568	112x	freeCovs(modPar.getFreeCovs(fpInfo, freeUcs, dim, maxDim)),
569	112x	presentCovs(modPar.getPresentCovs()),
570	112x	birthprob(1.0),
571	112x	deathprob(0.0),
572	112x	moveprob(0.0),
573	112x	logMargLik(logMargLikNullModel),
574	112x	logPrior(R_NaN)
575		{
576		}
577
578		ModelPar modPar;
579		PosInt dim; // number of columns in this model's design matrix
580
581		IntSet freeUcs; // indices within uc groups, denoting the birthable ones
582		PosIntSet freeCovs; // indices of free covs (starting from first fp with index 1 up to uc index = nFps + 1)
583		PosIntSet presentCovs; // analogue
584
585		double birthprob, deathprob, moveprob; // move type probabilities, switchprob is 1-bprob-dprob-mprob.
586		double logMargLik;
587		double logPrior;
588		};
589
590		// ***************************************************************************************************//
591
592		#endif /DATASTRUCTURE_H_/

1		/*
2		* distributions.h
3		*
4		* Created on: 15.03.2010
5		* Author: daniel
6		*
7		* Classes for exponential family distributions.
8		*
9		*/
10
11		#ifndef DISTRIBUTIONS_H_
12		#define DISTRIBUTIONS_H_
13
14		#include "types.h"
15		#include "rcppExport.h"
16
17
18		// ***************************************************************************************************//
19
20		// General virtual class for an exponential family distribution, including
21		// the variance function of the modelled mean mu
22		// and the loglikelihood of a whole vector of modelled means.
23		// We also always save the vector of scalar responses and weights, because naturally
24		// the loglikelihood of "means" depends on this!
25		class Distribution
26		{
27		public:
28		// ctr:
29	114x	Distribution(const AVector& responses,
30	114x	const AVector& weights) :
31	114x	responses(responses),
32	114x	weights(weights)
33		{
34		}
35
36		// variance function
37		virtual double
38		variance(double mu) const = 0;
39
40		// loglikelihood
41		virtual double
42		loglik(const double *means) const = 0;
43
44		// we need a virtual destructor here,
45		// cf. Accelerated C++ pp. 242 ff.
46	798x	virtual ~Distribution(){}
47
48		protected:
49		// the vector of responses
50		const AVector responses;
51
52		// the vector of weights
53		const AVector weights;
54		};
55
56		// ***************************************************************************************************//
57
58		// The binomial distribution
59		class Binomial : public Distribution
60		{
61		public:
62		// ctr
63	12x	Binomial(const AVector& responses,
64	12x	const AVector& weights) :
65		Distribution(responses,
66	12x	weights)
67		{
68		}
69
70		// variance function
71		double
72	319705484x	variance(double mu) const
73		{
74	319705484x	return mu * (1.0 - mu);
75		}
76
77		// loglikelihood
78		double
79		loglik(const double *means) const;
80		};
81
82		// ***************************************************************************************************//
83
84		// The Gaussian distribution
85		class Gaussian : public Distribution
86		{
87		public:
88		// ctr
89	102x	Gaussian(const AVector& responses,
90		const AVector& weights,
91	102x	double phi) :
92		Distribution(responses, weights),
93	102x	phi(phi)
94		{
95		}
96
97		// variance function
98		double
99	714x	variance(double mu) const
100		{
101	714x	return 1.0;
102		}
103
104		// loglikelihood
105		double
106		loglik(const double *means) const;
107
108		private:
109
110		// the dispersion factor (variance sigma^2)
111		const double phi;
112		};
113
114		// ***************************************************************************************************//
115
116		// The Poisson distribution
117		class Poisson : public Distribution
118		{
119		public:
120		// ctr
121	!	Poisson(const AVector& responses,
122	!	const AVector& weights) :
123		Distribution(responses,
124	!	weights)
125		{
126		}
127
128		// variance function
129		double
130	!	variance(double mu) const
131		{
132	!	return mu;
133		}
134
135		// loglikelihood
136		double
137		loglik(const double *means) const;
138		};
139
140
141		#endif /* DISTRIBUTIONS_H_ */

1		/*
2		* gpriors.h
3		*
4		* Created on: 15.03.2010
5		* Author: daniel
6		*
7		* Classes for priors on the shrinkage paramater g.
8		*
9		*/
10
11		#ifndef GPRIORS_H_
12		#define GPRIORS_H_
13
14		#include "rcppExport.h"
15		#include "functionWraps.h"
16
17
18		// ***************************************************************************************************//
19
20		// Virtual base class for all g priors.
21		struct GPrior
22		{
23		// Log prior density
24		virtual double
25		logDens(double g) const = 0;
26
27		// we need a virtual destructor here,
28		// cf. Accelerated C++ pp. 242 ff.
29	399x	virtual ~GPrior(){}
30
31		// add method which is only overwritten by the incomplete inverse gamma class
32		virtual double
33	8659x	getTBFLogMargLik(double residualDeviance, int df) const
34		{
35	8659x	return R_NaReal;
36		}
37		};
38
39		// ***************************************************************************************************//
40
41		// Inverse gamma g prior
42		class InvGammaGPrior : public GPrior
43		{
44		public:
45		// ctr
46	42x	InvGammaGPrior(double a, double b) :
47	42x	a(a),
48	42x	b(b)
49		{
50		}
51
52		// Log prior density
53		double
54	98007x	logDens(double g) const
55		{
56	98007x	return - (a + 1.0) * log(g) - b / g + a * log(b) - Rf_lgammafn(a);
57		}
58
59		private:
60		// the parameters for the inverse gamma density
61		const double a;
62		const double b;
63		};
64
65		// ***************************************************************************************************//
66
67		// Incomplete Inverse gamma g prior
68
69		class IncInvGammaGPrior : public GPrior
70		{
71		public:
72		// ctr
73	!	IncInvGammaGPrior(double a, double b) :
74	!	a(a),
75	!	b(b)
76		{
77		}
78
79		// Log prior density
80		double
81		logDens(double g) const;
82
83		// for this class we have a closed form for the log marginal likelihood
84		// resulting from the TBF approach
85		double
86		getTBFLogMargLik(double residualDeviance, int df) const;
87
88		private:
89		// the parameters for the inverse gamma density
90		const double a;
91		const double b;
92		};
93
94		// ***************************************************************************************************//
95
96		// Hyper-g prior
97		class HypergPrior : public GPrior
98		{
99		public:
100		// ctr
101	!	HypergPrior(double a) :
102	!	a(a)
103		{
104		}
105
106		// Log prior density
107		double
108	!	logDens(double g) const
109		{
110	!	return log(a - 2.0) - M_LN2 - (a / 2.0) * log1p(g);
111		}
112
113		private:
114		// the hyperparameter
115		const double a;
116		};
117
118		// ***************************************************************************************************//
119
120		// Custom g-prior
121		class CustomGPrior : public GPrior
122		{
123		public:
124		// ctr
125	357x	CustomGPrior(SEXP R_function) :
126	357x	wrappedRfunction(R_function)
127		{
128		}
129
130		// Log prior density
131		double
132	1123514x	logDens(double g) const
133		{
134	1123514x	return wrappedRfunction(g);
135		}
136
137		private:
138		// the wrapped R function
139		const RFunction wrappedRfunction;
140		};
141
142		// ***************************************************************************************************//
143
144
145		#endif /* GPRIORS_H_ */

1		/*
2		* links.h
3		*
4		* Created on: 15.03.2010
5		* Author: daniel
6		*
7		* Classes for GLM link functions.
8		*
9		*/
10
11		#ifndef LINKS_H_
12		#define LINKS_H_
13
14		#include "rcppExport.h"
15
16		static const double THRESH = 30.;
17		static const double MTHRESH = -30.;
18		static const double INVEPS = 1 / DBL_EPSILON;
19
20
21		// ***************************************************************************************************//
22
23		// The general virtual Link class, which includes
24		// the link function itself,
25		// the inverse link function (or response function)
26		// and the derivative of the response function.
27		class Link
28		{
29		public:
30		// the link function itself
31		virtual double
32		linkfun(double mu) const = 0;
33
34		// the inverse link function (or response function)
35		virtual double
36		linkinv(double eta) const = 0;
37
38		// and the derivative of the response function
39		virtual double
40		mu_eta(double eta) const = 0;
41
42		// we need a virtual destructor here,
43		// cf. Accelerated C++ pp. 242 ff.
44	912x	virtual ~Link(){}
45		};
46
47		// ***************************************************************************************************//
48
49		// the Logit link class
50		// inspiration taken from R/src/library/stats/src/family.c,
51		// because for numerical stability of the IWLS we REALLY NEED the thresholds...
52		class LogitLink : public Link
53		{
54		private:
55
56		/**
57		* Evaluate x/(1 - x). An inline function is used so that x is
58		* evaluated once only.
59		*/
60	192x	static double x_d_omx(double x)
61		{
62	192x	if (x < 0 \|\| x > 1)
63	!	Rf_error("Value %f out of range (0, 1)", x);
64	192x	return x / (1 - x);
65		}
66
67		/**
68		* Evaluate x/(1 + x). An inline function is used so that x is
69		* evaluated once only.
70		*/
71	594784608x	static double x_d_opx(double x)
72		{
73	594784608x	return x / (1 + x);
74		}
75
76		public:
77		// logit
78		double
79	192x	linkfun(double mu) const
80		{
81	192x	return log(x_d_omx(mu));
82		}
83
84		// inverse logit
85		double
86	594784608x	linkinv(double eta) const
87		{
88		double tmp = (eta < MTHRESH) ? DBL_EPSILON :
89		((eta > THRESH) ? INVEPS : exp(eta));
90	594784608x	return x_d_opx(tmp);
91		}
92
93		// function(eta) h'(eta) where h is the inverse logit
94		double
95	365377696x	mu_eta(double eta) const
96		{
97	365377696x	double opexp = 1 + exp(eta);
98		double ret = (eta > THRESH \|\| eta < MTHRESH) ? DBL_EPSILON :
99	365377696x	exp(eta) / (opexp * opexp);
100	365377696x	return ret;
101		}
102		};
103
104
105		// ***************************************************************************************************//
106
107		// the Cauchit link class
108		class CauchitLink : public Link
109		{
110		public:
111		// ctr
112		CauchitLink() :
113		thresh(- Rf_qcauchy(DBL_EPSILON, 0.0, 1.0, 1, 0))
114		{
115		}
116
117		// cauchit == cauchy quantile
118		double
119		linkfun(double mu) const
120		{
121		return Rf_qcauchy(mu, 0.0, 1.0, 1, 0);
122		}
123
124		// inverse cauchit == cauchy cdf
125		// compare in R: binomial("cauchit")$linkinv
126		double
127		linkinv(double eta) const
128		{
129		eta = fmin(fmax(eta, - thresh), thresh);
130		return Rf_pcauchy(eta, 0.0, 1.0, 1, 0);
131		}
132
133		// cauchy density
134		double
135		mu_eta(double eta) const
136		{
137		return fmax(Rf_dcauchy(eta, 0.0, 1.0, 0), DBL_EPSILON);
138		}
139
140		private:
141		const double thresh;
142		};
143
144		// ***************************************************************************************************//
145
146		// the Probit link class
147		class ProbitLink : public Link
148		{
149		public:
150		// ctr
151	!	ProbitLink() :
152	!	thresh(- Rf_qnorm5(DBL_EPSILON, 0.0, 1.0, 1, 0))
153		{
154		}
155
156		// probit == normal quantile
157		double
158	!	linkfun(double mu) const
159		{
160	!	return Rf_qnorm5(mu, 0.0, 1.0, 1, 0);
161		}
162
163		// inverse probit == normal cdf
164		// compare in R: binomial("probit")$linkinv
165		double
166	!	linkinv(double eta) const
167		{
168	!	eta = fmin(fmax(eta, - thresh), thresh);
169	!	return Rf_pnorm5(eta, 0.0, 1.0, 1, 0);
170		}
171
172		// normal density
173		double
174	!	mu_eta(double eta) const
175		{
176	!	return fmax(Rf_dnorm4(eta, 0.0, 1.0, 0), DBL_EPSILON);
177		}
178
179		private:
180		const double thresh;
181		};
182
183		// ***************************************************************************************************//
184
185		// the complementary log-log link class
186		class CloglogLink : public Link
187		{
188		public:
189		// cloglog
190		double
191	!	linkfun(double mu) const
192		{
193	!	return log(- log(1.0 - mu));
194		}
195
196		// compare in R: binomial("cloglog")$linkinv
197		double
198	!	linkinv(double eta) const
199		{
200	!	return fmax(fmin(- expm1(- exp(eta)), 1 - DBL_EPSILON), DBL_EPSILON);
201		}
202
203		// compare in R: binomial("cloglog")$mu.eta
204		double
205	!	mu_eta(double eta) const
206		{
207	!	eta = fmin(eta, 700.0);
208	!	return fmax(exp(eta) * exp(- exp(eta)), DBL_EPSILON);
209		}
210		};
211
212		// ***************************************************************************************************//
213
214		// the inverse link class
215		class InverseLink : public Link
216		{
217		public:
218		// inverse is the link
219		double
220	!	linkfun(double mu) const
221		{
222	!	return 1.0 / mu;
223		}
224
225		// and also the response function
226		double
227	!	linkinv(double eta) const
228		{
229	!	return 1.0 / eta;
230		}
231
232		// finally the response derivative
233		double
234	!	mu_eta(double eta) const
235		{
236	!	return - 1.0 / eta / eta;
237		}
238		};
239
240		// ***************************************************************************************************//
241
242		// the log link class
243		class LogLink : public Link
244		{
245		public:
246		// log is the link
247		double
248	!	linkfun(double mu) const
249		{
250	!	return log(mu);
251		}
252
253		// so the response function is exp
254		double
255	!	linkinv(double eta) const
256		{
257	!	return fmax(exp(eta), DBL_EPSILON);
258		}
259
260		// finally the response derivative is also exp
261		double
262	!	mu_eta(double eta) const
263		{
264	!	return fmax(exp(eta), DBL_EPSILON);
265		}
266		};
267
268		// ***************************************************************************************************//
269
270		// the identity link class
271		class IdentityLink : public Link
272		{
273		public:
274		// identity is the link ...
275		double
276	1632x	linkfun(double mu) const
277		{
278	1632x	return mu;
279		}
280
281		// ... and response function
282		double
283	816x	linkinv(double eta) const
284		{
285	816x	return eta;
286		}
287
288		// finally the response derivative is 1
289		double
290	816x	mu_eta(double eta) const
291		{
292	816x	return 1.0;
293		}
294		};
295		#endif /* LINKS_H_ */

1		/*
2		* rcppExport.h
3		*
4		* Created on: 13.10.2010
5		* Author: daniel
6		*/
7
8		#ifndef RCPPEXPORT_H_
9		#define RCPPEXPORT_H_
10
11		#include <RcppCommon.h>
12
13		// load the library defining the templated class
14		#include <set>
15
16		// declaring the partial specialization
17		namespace Rcpp
18		{
19		namespace traits
20		{
21		template <typename T> class Exporter<std::set<T> >;
22		}
23		}
24
25
26		// this must appear after the specialization,
27		// otherwise the specialization will not be seen by Rcpp types
28		#include <RcppArmadillo.h>
29
30
31		// only now the implementation of the new Exporter class:
32		namespace Rcpp
33		{
34		namespace traits
35		{
36		template <typename T> class Exporter<std::set<T> >
37		{
38		public:
39		// we need a constructor taking an SEXP
40	1344x	Exporter(SEXP s) :
41	1344x	_x(s)
42		{
43		}
44
45		// and we need a method called "get" that returns an instance of the wished type:
46		inline std::set<T>
47	1344x	get()
48		{
49		// allocate return set
50	1344x	std::set<T> x;
51
52		// insert all elements in _x into the return set x:
53	3248x	for (R_len_t i = 0; i < _x.size(); ++i)
54		{
55	1904x	x.insert(_x[i]);
56		}
57
58		// return the result
59	1344x	return x;
60		}
61
62		private:
63		Rcpp::IntegerVector _x;
64		};
65		}
66		}
67
68
69		#endif /* RCPPEXPORT_H_ */

1		#ifndef SUM_H_
2		#define SUM_H_
3
4		// Source: http://oldmill.uchicago.edu/~wilder/Code/sum/
5
6		#include <cmath>
7		#include <vector>
8
9		using std::vector;
10
11		//========================================================================
12		// The condensed summation algorithm of Kahan. Avoids common round-off
13		// errors in computing the sum of a bunch of numbers. It works well for
14		// most cases, but can fail badly when there is cancellation. The
15		// slower modified_deflation algorithm below does better in those cases.
16
17		template<class T>
18		T
19	76896x	condensed_summation(const vector<T>& v)
20		{
21	76896x	T a, b, sum = 0.0, error = 0.0;
22	1169440x	for (typename vector<T>::const_iterator i = v.begin(); i != v.end(); ++i)
23		{
24	1092544x	a = sum;
25	1092544x	b = * i + error;
26	1092544x	sum = a + b;
27	1092544x	error = (a - sum) + b;
28		}
29	76896x	return sum;
30
31		} // condensed_summation
32
33		//========================================================================
34		// The modified deflation algorithm of Anderson. It is reasonably fast,
35		// and should give the correct result as it is difficult if not impossible
36		// to do better without increasing the precision of the variables. The
37		// portion of the algorithm that handles potentially infinite loops has
38		// been modified as the original version did not always work in my tests.
39		// I believe the failures were due to errors in g++ optimizations and
40		// also believe that my code still has an error.
41
42		template<class T>
43		T
44	25632x	modified_deflation(const vector<T>& v)
45		{
46	25632x	if (v.size() < 3)
47	!	return condensed_summation(v);
48
49		// Set up several vectors
50	25632x	vector<T> vp;
51	25632x	vector<T> vn;
52	25632x	vector<T> e;
53
54		// we do not need to do this:
55		// vp.reserve(v.size());
56		// vn.reserve(v.size());
57		// e.reserve(v.size());
58
59		// Initialize vectors of negative and positive elements of v
60	25632x	for (typename vector<T>::const_iterator
61	25632x	i = v.begin();
62	571904x	i != v.end();
63	546272x	++i)
64	546272x	if (* i < 0.0)
65	14784x	vn.push_back(* i);
66	531488x	else if (* i > 0.0)
67	531488x	vp.push_back(* i);
68
69
70		// immediately return 0 if there are no negative or positive elements
71		if(vn.empty() && vp.empty())
72	!	return static_cast<T>(0.0);
73
74		// now we are sure there is at least one non-zero element,
75		// and can start with the summation algorithm.
76
77		T a, b, sum, error, sp, sn;
78
79	25632x	bool well_conditioned = false;
80	51264x	while (! well_conditioned)
81		{
82		// Deflate the last elements of vp and vn.
83		while (! vp.empty() && ! vn.empty())
84		{
85	!	a = vp.back();
86	!	vp.pop_back();
87	!	b = vn.back();
88	!	vn.pop_back();
89	!	sum = a + b;
90	!	error = (a - sum) + b;
91	!	if (sum == a)
92		{ // \|a\| >> \|b\|
93	!	T tmp1 = a / 2.0;
94	!	T tmp2 = a - tmp1;
95	!	vp.push_back(tmp2);
96	!	vp.push_back(tmp1);
97	!	vn.push_back(b);
98		}
99	!	else if (sum == b)
100		{ // \|b\| >> \|a\|
101	!	T tmp1 = b / 2.0;
102	!	T tmp2 = b - tmp1;
103	!	vp.push_back(a);
104	!	vn.push_back(tmp2);
105	!	vn.push_back(tmp1);
106		}
107		else
108		{
109	!	if (sum < 0.0)
110	!	vn.push_back(sum);
111	!	else if (sum > 0.0)
112	!	vp.push_back(sum);
113
114	!	if (error != 0.0)
115	!	e.push_back(error);
116		}
117		}
118
119		// Put the error terms back in the vp and vn arrays.
120	25632x	for (typename vector<T>::iterator
121	25632x	i = e.begin();
122	25632x	i != e.end();
123	!	++i)
124		{
125	!	if (* i < 0.0)
126	!	vn.push_back(* i);
127	!	else if (* i > 0.0)
128	!	vp.push_back(* i);
129		}
130
131	25632x	e.clear();
132
133		// Check that the sums in vp and vn are well-conditioned.
134	25632x	sp = condensed_summation(vp);
135	25632x	sn = condensed_summation(vn);
136	25632x	well_conditioned = (std::abs((sp + sn) / (sp - sn)) == 1.0);
137		}
138
139	25632x	vector<T> vnew;
140	25632x	vnew.reserve(vp.size() + vn.size());
141
142	25632x	vnew.insert(vnew.end(), vp.begin(), vp.end());
143	25632x	vnew.insert(vnew.end(), vn.begin(), vn.end());
144
145	25632x	return condensed_summation(vnew);
146
147	25632x	} // modified_deflation
148
149
150		#endif /SUM_H_/

1		/*
2		* design.cpp
3		*
4		* Created on: 09.11.2009
5		* Author: daniel
6		*/
7
8		#include "design.h"
9		#include "fpUcHandling.h"
10		#include "dataStructure.h"
11
12		#include "rcppExport.h"
13		#include "types.h"
14
15		#include <algorithm>
16
17
18		// get different concatenated columns of matrix
19		AMatrix
20	23505x	getMultipleCols(const AMatrix& m,
21		const PosIntVector& s) // expect that the column numbers s are 1-based!
22		{
23	23505x	AMatrix ret(m.n_rows, s.size());
24
25	23505x	PosIntVector::size_type cols = 0; // invariant: about to process column nr. "cols"
26	55440x	for (PosIntVector::const_iterator i = s.begin(); i != s.end(); i++)
27		{
28	95805x	ret.col(cols++) = m.col(*i - 1); // so we must subtract 1 here
29		}
30
31	23505x	return ret;
32		}
33
34
35		// ***************************************************************************************************//
36
37		// build Fp basis matrix from vector, power indices and power set for one covariate
38		AMatrix
39	43470x	getFpMatrix(const std::vector<AVector>& tcols,
40		const Powers& powerinds,
41		const DataValues& data)
42		{
43	43470x	const int logInd = 3; // this index corresponds to power = 0, i.e. log.
44	43470x	const int nrow = tcols.at(1).n_elem;
45
46		// get the log column
47	43470x	const AVector& logColumn = tcols.at(logInd);
48
49		// this will be the returned matrix
50	43470x	AMatrix ret(nrow, powerinds.size());
51
52		// start recursion
53	43470x	int lastInd = logInd;
54	86940x	AVector lastCol = arma::ones<AVector>(nrow);
55
56		// there is at least one power present
57	43470x	Powers::size_type cols = 0; // invariant: about to process column number "cols"
58
59	43470x	for (Powers::const_iterator
60	43470x	now = powerinds.begin();
61	87180x	now != powerinds.end();
62	43710x	now++)
63		{
64	43710x	if (*now == lastInd)
65		{ // repeated powers case:
66
67		// elementwise multiplication (Schur product):
68	12120x	lastCol = lastCol % logColumn;
69		}
70		else
71		{ // normal case
72
73	37650x	lastInd = *now;
74	37650x	lastCol = tcols.at(lastInd);
75		}
76		// center the column
77	131130x	ret.col(cols++) = lastCol - arma::mean(lastCol);
78		}
79
80	86940x	return ret;
81		}
82
83		// ***************************************************************************************************//
84
85		// construct centered design matrix including intercept for the model
86		// optionally the intercept column is not included
87		AMatrix
88	24135x	getDesignMatrix(const ModelPar &mod,
89		const DataValues &data,
90		const FpInfo &fpInfo,
91		const UcInfo& ucInfo,
92		const FixInfo& fixInfo,
93		bool includeIntercept)
94		{
95		// total number of columns
96	24135x	int nColumns = mod.size(ucInfo, fixInfo);
97	24135x	if(includeIntercept)
98		{
99	1950x	++nColumns;
100		}
101
102		// initialize the return matrix
103	24135x	AMatrix ret(data.nObs, nColumns);
104
105		// invariant: nextColumn is the next column to be written
106	24135x	PosInt nextColumn = 0;
107
108		// start with the intercept column?
109	24135x	if(includeIntercept)
110		{
111	3900x	ret.col(0) = data.onesVector;
112	1950x	++nextColumn;
113		}
114
115		// go on with centered fp matrices
116	95025x	for (PosInt i = 0; i != fpInfo.nFps; i++)
117		{
118	70890x	Powers powersi = mod.fpPars.at(i);
119
120	70890x	if (! powersi.empty())
121		{
122		// what is the end column in the return matrix?
123	43470x	PosInt endColumn = nextColumn + powersi.size() - 1;
124
125		// insert the centered FP matrix into the return matrix
126	86940x	ret.cols(nextColumn, endColumn) = getFpMatrix(fpInfo.tcols.at(i), powersi, data);
127
128		// correct invariant
129	43470x	nextColumn = endColumn + 1;
130		}
131		}
132
133		// centered uc matrices
134	24135x	for(IntSet::const_iterator
135	24135x	g = mod.ucPars.begin();
136	47640x	g != mod.ucPars.end();
137	23505x	++g)
138		{
139		// the C index is
140	23505x	Int i = *g - 1;
141
142		// what is the column list for this covariate?
143	23505x	PosIntVector thisColList = ucInfo.ucColList.at(i);
144
145		// what is the end column in the return matrix?
146	23505x	PosInt endColumn = nextColumn + thisColList.size() - 1;
147
148		// insert the centered UC matrix into the return matrix
149	47010x	ret.cols(nextColumn, endColumn) = getMultipleCols(data.centeredDesign, thisColList);
150
151		// correct invariant
152	23505x	nextColumn = endColumn + 1;
153		}
154
155
156		// centered fix matrices
157	24135x	for(IntSet::const_iterator
158	24135x	g = mod.fixPars.begin();
159	24135x	g != mod.fixPars.end();
160	!	++g)
161		{
162		// the C index is
163	!	Int i = *g - 1;
164
165		// what is the column list for this covariate?
166	!	PosIntVector thisColList = fixInfo.fixColList.at(i);
167
168		// what is the end column in the return matrix?
169	!	PosInt endColumn = nextColumn + thisColList.size() - 1;
170
171		// insert the centered UC matrix into the return matrix
172	!	ret.cols(nextColumn, endColumn) = getMultipleCols(data.centeredDesign, thisColList);
173
174		// correct invariant
175	!	nextColumn = endColumn + 1;
176		}
177
178
179	24135x	return ret;
180		}
181
182		// ***************************************************************************************************//
183
184
185
186		// End of file.

1		/*
2		* distributions.cpp
3		*
4		* Created on: 15.03.2010
5		* Author: daniel
6		*
7		* Implementation of classes for exponential family distributions,
8		* i.e. functions which should not be inlined by the compiler.
9		*
10		*/
11
12		#include "distributions.h"
13		#include <string>
14		#include "types.h"
15		#include "rcppExport.h"
16
17		// ***************************************************************************************************//
18
19		// helper function for the binomial and Poisson loglikelihood
20		// see R/src/library/stats/src/family.c for the original R source code.
21		static inline double
22	208558896x	y_log_y(double y, double mu)
23		{
24	208558896x	return (y > 0.0) ? (y * log(y / mu)) : 0.0;
25		}
26
27		// ***************************************************************************************************//
28
29
30		// binomial loglikelihood
31		// compare in R: binomial()$dev.resids
32		double
33	196014x	Binomial::loglik(const double *means) const
34		{
35	196014x	double ret = 0.0;
36
37	104475462x	for(PosInt i = 0; i < responses.n_elem; ++i, ++means)
38		{
39	417117792x	ret += weights(i) * (y_log_y(responses(i), means) + y_log_y(1.0 - responses(i), 1.0 - means));
40		}
41
42	196014x	return - ret;
43		}
44
45		// ***************************************************************************************************//
46
47
48		// Gaussian loglikelihood
49		// compare in R: poisson()$dev.resids
50		double
51	!	Gaussian::loglik(const double *means) const
52		{
53	!	double ret = 0.0;
54
55	!	for(PosInt i = 0; i < responses.n_elem; ++i, ++means)
56		{
57	!	ret += weights(i) * (responses(i) - means) (responses(i) - *means);
58		}
59
60	!	return - 0.5 * ret / phi;
61		}
62
63		// ***************************************************************************************************//
64
65
66		// Poisson loglikelihood
67		// compare in R: poisson()$dev.resids
68		double
69	!	Poisson::loglik(const double *means) const
70		{
71	!	double ret = 0.0;
72
73	!	for(PosInt i = 0; i < responses.n_elem; ++i, ++means)
74		{
75	!	ret += weights(i) * (responses(i) - means - y_log_y(responses(i), means));
76		}
77
78	!	return ret;
79		}

1		/*
2		* evalZdensity.cpp
3		*
4		* Created on: 16.05.2010
5		* Author: daniel
6		*/
7
8
9		#include "rcppExport.h"
10		#include "dataStructure.h"
11		#include "types.h"
12		#include "zdensity.h"
13		#include "fpUcHandling.h"
14		#include <stdexcept>
15
16		using namespace Rcpp;
17
18		// ***************************************************************************************************//
19
20
21		// R call is:
22		//
23		// samples <- .External(cpp_evalZdensity,
24		// config,
25		// attrs$data,
26		// attrs$fpInfos,
27		// attrs$ucInfos,
28		// attrs$fixInfos,
29		// attrs$distribution,
30		// options)
31		// [[Rcpp::export]]
32		SEXP
33	13x	cpp_evalZdensity(List rcpp_config, List rcpp_data, List rcpp_fpInfos, List rcpp_ucInfos,
34		List rcpp_fixInfos, List rcpp_distribution, List rcpp_options)
35		{
36		// ----------------------------------------------------------------------------------
37		// extract arguments
38		// ----------------------------------------------------------------------------------
39
40		// r_interface = CDR(r_interface);
41		// List rcpp_config(CAR(r_interface));
42		//
43		// r_interface = CDR(r_interface);
44		// List rcpp_data(CAR(r_interface));
45		//
46		// r_interface = CDR(r_interface);
47		// List rcpp_fpInfos(CAR(r_interface));
48		//
49		// r_interface = CDR(r_interface);
50		// List rcpp_ucInfos(CAR(r_interface));
51		//
52		// r_interface = CDR(r_interface);
53		// List rcpp_fixInfos(CAR(r_interface));
54		//
55		// r_interface = CDR(r_interface);
56		// List rcpp_distribution(CAR(r_interface));
57		//
58		// r_interface = CDR(r_interface);
59		// List rcpp_options(CAR(r_interface));
60
61		// ----------------------------------------------------------------------------------
62		// unpack the R objects
63		// ----------------------------------------------------------------------------------
64
65		// data:
66
67	26x	const NumericMatrix n_x = rcpp_data["x"];
68	13x	const AMatrix x(n_x.begin(), n_x.nrow(),
69	13x	n_x.ncol());
70
71	26x	const NumericMatrix n_xCentered = rcpp_data["xCentered"];
72	13x	const AMatrix xCentered(n_xCentered.begin(), n_xCentered.nrow(),
73	13x	n_xCentered.ncol());
74
75	26x	const NumericVector n_y = rcpp_data["y"];
76	13x	const AVector y(n_y.begin(), n_y.size());
77
78	26x	const IntVector censInd = as<IntVector>(rcpp_data["censInd"]);
79
80		// FP configuration:
81
82		// vector of maximum fp degrees
83	26x	const PosIntVector fpmaxs = as<PosIntVector>(rcpp_fpInfos["fpmaxs"]);
84		// corresponding vector of fp column indices
85	26x	const PosIntVector fppos = rcpp_fpInfos["fppos"];
86		// corresponding vector of power set cardinalities
87	26x	const PosIntVector fpcards = rcpp_fpInfos["fpcards"];
88		// names of fp terms
89	26x	const StrVector fpnames = rcpp_fpInfos["fpnames"];
90
91
92		// UC configuration:
93
94	26x	const PosIntVector ucIndices = rcpp_ucInfos["ucIndices"];
95	26x	List rcpp_ucColList = rcpp_ucInfos["ucColList"];
96
97	13x	std::vector<PosIntVector> ucColList;
98		for (R_len_t i = 0; i != rcpp_ucColList.length(); ++i)
99		{
100	!	ucColList.push_back(as<PosIntVector>(rcpp_ucColList[i]));
101		}
102
103		// fixed covariate configuration:
104
105	26x	const PosIntVector fixIndices = rcpp_fixInfos["fixIndices"];
106	26x	List rcpp_fixColList = rcpp_fixInfos["fixColList"];
107
108	13x	std::vector<PosIntVector> fixColList;
109		for (R_len_t i = 0; i != rcpp_fixColList.length(); ++i)
110		{
111	!	fixColList.push_back(as<PosIntVector>(rcpp_fixColList[i]));
112		}
113
114
115		// distributions info:
116
117	13x	const double nullModelLogMargLik = as<double>(rcpp_distribution["nullModelLogMargLik"]);
118	13x	const double nullModelDeviance = as<double>(rcpp_distribution["nullModelDeviance"]);
119	13x	const double empiricalMean = as<double>(rcpp_distribution["yMean"]);
120	26x	S4 rcpp_gPrior = rcpp_distribution["gPrior"];
121	26x	List rcpp_family = rcpp_distribution["family"];
122
123
124
125		// options:
126
127	26x	const MyDoubleVector zValues = rcpp_options["zValues"];
128		// const bool conditional = as<bool>(rcpp_options["conditional"]);
129		// const bool debug = as<bool>(rcpp_options["debug"]);
130		// const bool higherOrderCorrection = as<bool>(rcpp_options["higherOrderCorrection"]);
131
132	26x	const Book bookkeep(as<bool>(rcpp_distribution["tbf"]),
133	26x	as<bool>(rcpp_distribution["doGlm"]),
134		false,
135	26x	as<bool>(rcpp_options["conditional"]),
136		false, //useFixedc
137		100,
138		false,
139	26x	as<bool>(rcpp_options["debug"]),
140	26x	as<std::string>(rcpp_distribution["modelPrior"]),
141		10,
142		10,
143		10,
144		false,
145	26x	as<bool>(rcpp_options["debug"]),
146	91x	as<bool>(rcpp_options["higherOrderCorrection"]));
147
148
149		// ----------------------------------------------------------------------------------
150		// further process arguments
151		// ----------------------------------------------------------------------------------
152
153		// data:
154
155		// only the intercept is always included, that is fixed, in the model
156	13x	IntSet fixedCols;
157	13x	fixedCols.insert(1);
158
159		// totalnumber is set to 0 because we do not care about it.
160	13x	const DataValues data(x, xCentered, y, censInd, 0, fixedCols);
161
162		// FP configuration:
163	13x	const FpInfo fpInfo(fpcards, fppos, fpmaxs, fpnames, x);
164
165		// UC configuration:
166
167		// determine sizes of the UC groups, and the total size == maximum size reached together by all
168		// UC groups.
169	13x	PosIntVector ucSizes;
170	13x	PosInt maxUcDim = 0;
171		for (std::vector<PosIntVector>::const_iterator cols = ucColList.begin(); cols != ucColList.end(); ++cols)
172		{
173	!	PosInt thisSize = cols->size();
174
175	!	maxUcDim += thisSize;
176	!	ucSizes.push_back(thisSize);
177		}
178	13x	const UcInfo ucInfo(ucSizes, maxUcDim, ucIndices, ucColList);
179
180
181
182
183		// fix configuration: //TODO THIS SECTION
184
185		// determine sizes of the fix groups, and the total size == maximum size reached together by all
186		// fix groups.
187	13x	PosIntVector fixSizes;
188	13x	PosInt maxFixDim = 0;
189		for (std::vector<PosIntVector>::const_iterator cols = fixColList.begin(); cols != fixColList.end(); ++cols)
190		{
191	!	PosInt thisSize = cols->size();
192
193	!	maxFixDim += thisSize;
194	!	fixSizes.push_back(thisSize);
195		}
196	13x	const FixInfo fixInfo(fixSizes, maxFixDim, fixIndices, fixColList);
197
198
199		// search configuration:
200		const GlmModelConfig config(rcpp_family, nullModelLogMargLik, nullModelDeviance, as<double>(rcpp_distribution["fixedg"]), rcpp_gPrior,
201	13x	data.response, bookkeep.debug, bookkeep.useFixedc, empiricalMean,
202	26x	as<bool>(rcpp_distribution["empiricalgPrior"]));
203		// config of this model:
204	13x	const ModelPar thisModelConfig(rcpp_config, fpInfo);
205
206
207		// ----------------------------------------------------------------------------------
208		// evaluate the z density
209		// ----------------------------------------------------------------------------------
210
211		// get negative log unnormalized z density: a function object.
212		NegLogUnnormZDens negLogUnnormZDens(thisModelConfig,
213		data,
214		fpInfo,
215		ucInfo,
216		fixInfo,
217		config,
218	13x	bookkeep);
219
220		// evaluate it at the given z values.
221	13x	NumericVector results;
222
223	1235x	for (MyDoubleVector::const_iterator z = zValues.begin(); z != zValues.end(); ++z)
224		{
225	1222x	results.push_back(negLogUnnormZDens(* z));
226		}
227
228		// return the results vector
229	26x	return results;
230		}

1		/*
2		* fpUcHandling.h
3		*
4		* Created on: 09.11.2009
5		* Author: daniel
6		*/
7
8		#ifndef FPUCHANDLING_H_
9		#define FPUCHANDLING_H_
10
11		#include "types.h"
12		#include <numeric>
13		#include "rcppExport.h"
14
15		// ***************************************************************************************************//
16
17		// small helper function to structure code:
18		// get the maximum power set for a range of FP maximum degrees
19		MyDoubleVector
20		getMaxPowerSet(const PosIntVector& fpmaxs);
21
22		// ***************************************************************************************************//
23
24		// build array of vectors of ColumnVectors holding the required transformed values for the design matrices
25		// do not! center the column. This is done inside getFpMatrix, because the repeated powers case cannot
26		// be treated here.
27		AVectorArray
28		getTransformedCols(const PosIntVector& fpcards,
29		const PosIntVector& fppos,
30		const PosIntVector& fpmaxs,
31		const AMatrix& x);
32
33
34		// ***************************************************************************************************//
35
36
37		struct FpInfo
38		{ // collects all information on fractional polynomials needed to be passed down
39		PosInt nFps;
40		MyDoubleVector powerset;
41		PosIntVector fpcards;
42		PosIntVector fppos;
43		PosIntVector fpmaxs;
44		StrVector fpnames;
45		AVectorArray tcols;
46		PosInt maxFpDim;
47
48		// number of possible univariate fps for each FP?
49		IntVector numberPossibleFps;
50
51		// what is the multiset expressing a linear inclusion of a covariate?
52		Powers linearPowers;
53
54
55		// ctr
56	171x	FpInfo(const PosIntVector& fpcards,
57		const PosIntVector& fppos,
58		const PosIntVector& fpmaxs,
59		const StrVector& fpnames,
60	171x	const AMatrix& x) :
61	171x	nFps(fpmaxs.size()), powerset(getMaxPowerSet(fpmaxs)), fpcards(fpcards),
62	171x	fppos(fppos), fpmaxs(fpmaxs), fpnames(fpnames), tcols(getTransformedCols(fpcards, fppos, fpmaxs, x)),
63	171x	maxFpDim(std::accumulate(fpmaxs.begin(), fpmaxs.end(), 0)),
64	171x	numberPossibleFps(),
65	171x	linearPowers()
66		{
67		// numbers of possible univariate fps?
68	345x	for(PosInt i=0; i != nFps; ++i)
69		{
70	174x	int thisNumber = 0;
71	648x	for(PosInt deg = 0; deg <= fpmaxs[i]; ++deg)
72		{
73	474x	thisNumber += Rf_choose(fpcards[i] - 1 + deg, deg);
74		}
75	174x	numberPossibleFps.push_back(thisNumber);
76		}
77
78		// insert the index 5 for linear power 1
79	171x	linearPowers.insert(5);
80
81		}
82
83		// convert inds m into powers vector
84		MyDoubleVector
85		inds2powers(const Powers& m) const;
86
87		// convert std::vector of powers into Powers object (i.e. a multiset)
88		Powers
89		vec2inds(const MyDoubleVector& p) const;
90
91		};
92
93		// ***************************************************************************************************//
94
95		// collects all information on uncertain fixed form covariates groups
96		struct UcInfo
97		{
98		const PosIntVector ucSizes;
99		const PosInt maxUcDim;
100		const PosIntVector ucIndices;
101		const std::vector <PosIntVector> ucColList;
102		const PosInt nUcGroups;
103
104	171x	UcInfo(const PosIntVector& ucSizes,
105		const PosInt maxUcDim,
106		const PosIntVector& ucIndices,
107	171x	const std::vector<PosIntVector>& ucColList) :
108	171x	ucSizes(ucSizes), maxUcDim(maxUcDim), ucIndices(ucIndices),
109	171x	ucColList(ucColList), nUcGroups(ucColList.size())
110		{
111		}
112		};
113
114		// ***************************************************************************************************//
115
116		// collects all information on fixed form covariates groups
117		struct FixInfo
118		{
119		const PosIntVector fixSizes;
120		const PosInt maxFixDim;
121		const PosIntVector fixIndices;
122		const std::vector <PosIntVector> fixColList;
123		const PosInt nFixGroups;
124
125	171x	FixInfo(const PosIntVector& fixSizes,
126		const PosInt maxFixDim,
127		const PosIntVector& fixIndices,
128	171x	const std::vector<PosIntVector>& fixColList) :
129	171x	fixSizes(fixSizes), maxFixDim(maxFixDim), fixIndices(fixIndices),
130	171x	fixColList(fixColList), nFixGroups(fixColList.size())
131		{
132		}
133		};
134
135		// ***************************************************************************************************//
136
137
138		// return iterator of random element of myset; should be enclosed in getRNGstate() etc.
139		template<class T>
140		typename T::iterator
141	1782944x	discreteUniform(const T& container)
142		{
143	1782944x	if (container.empty())
144		{
145	!	Rf_error("\ncontainer in call to discreteUniform is empty!\n");
146		}
147
148	1782944x	double u = unif_rand();
149
150	1782944x	typename T::size_type size = container.size();
151	1782944x	typename T::const_iterator i = container.begin();
152	1782944x	typename T::size_type j = 1;
153
154	2882048x	while (u > 1.0 / size * j)
155		{
156	549552x	i++;
157	549552x	j++;
158		}
159
160	1782944x	return i;
161		}
162
163		// ***************************************************************************************************//
164
165		// get random int x with lower <= x < upper; should be enclosed in getRNGstate() etc.
166		template<class INT>
167		INT
168	40784x	discreteUniform(const INT& lower, const INT& upper)
169		{
170	40784x	if (lower >= upper)
171		{
172	!	Rf_error("\nlower = %d >= %d = upper in discreteUniform call\n", lower,
173		upper);
174		}
175
176	40784x	double u = unif_rand();
177
178	40784x	INT size = upper - lower;
179	40784x	INT ret = lower;
180
181	182432x	while (u > 1.0 / size * (ret - lower + 1))
182		{
183	141648x	ret++;
184		}
185
186	40784x	return ret;
187		}
188
189		// ***************************************************************************************************//
190
191
192		// delete a number from a set
193		template<class T>
194		typename std::set<T>
195	41440x	removeElement(std::set<T> input, T element)
196		{
197	41440x	typename std::set<T>::iterator iter = input.begin();
198	154928x	while (iter != input.end())
199		{
200	113488x	if (*iter == element)
201		// A copy of iter is passed into erase(), ++ is executed after erase().
202		// Thus iter remains valid
203	20720x	input.erase(iter++);
204		else
205	92768x	++iter;
206		}
207
208	82880x	return input;
209		}
210
211		// ***************************************************************************************************//
212
213		// construct a sequence 1:maximum
214		template<class T>
215		typename std::set<T>
216	112x	constructSequence(T maximum)
217		{
218	112x	std::set<T> ret;
219
220	400x	for (T i = 1; i <= maximum; ++i)
221		{
222	288x	ret.insert(ret.end(), i);
223		}
224
225	112x	return ret;
226		}
227
228		// ***************************************************************************************************//
229
230		// convert frequency vector into multiset
231		Powers
232		freqvec2Powers(IntVector& vec, const int &vecLength);
233
234		// ***************************************************************************************************//
235
236
237		#endif /* FPUCHANDLING_H_ */

1		/*
2		* zdensity.h
3		*
4		* Created on: 16.11.2009
5		* Author: daniel
6		*/
7
8		#ifndef ZDENSITY_H_
9		#define ZDENSITY_H_
10
11		#include "iwls.h"
12		#include "coxfit.h"
13		#include "types.h"
14
15		// 21/11/2012: major update due to inclusion of TBF methodology
16
17		class NegLogUnnormZDens {
18		public:
19
20		// call the function object:
21		// z is the argument,
22		double
23		operator()(double z);
24
25		// constructor
26		NegLogUnnormZDens(const ModelPar &mod,
27		const DataValues& data,
28		const FpInfo& fpInfo,
29		const UcInfo& ucInfo,
30		const FixInfo& fixInfo,
31		const GlmModelConfig& config,
32		// return the approximate conditional density f(y \| z, mod) by operator()?
33		// otherwise return the approximate unnormalized joint density f(y, z \| mod).
34		const Book& bookkeep,
35		PosInt nIter=40);
36
37		// try to get the TBF log marginal likelihood
38		double
39		getTBFLogMargLik() const;
40
41		// get the maximum log conditional marginal likelihood
42		// and put the local EB estimate into zMode
43		double
44		getTBFMaxLogCondMargLik(double& zMode) const;
45
46		// get residual deviance
47		double
48	15670x	getResidualDeviance() const
49		{
50	15670x	return modResidualDeviance;
51		}
52
53		// destructor
54	4704x	~NegLogUnnormZDens()
55		{
56	4704x	delete iwlsObject;
57	4704x	delete coxfitObject;
58		}
59
60		private:
61		// save the model reference and fp info, so we can write a nice warning message if the
62		// IWLS fails for some z
63		const ModelPar& mod;
64		const FpInfo& fpInfo;
65		const GlmModelConfig& config;
66		const Book& bookkeep;
67
68		// also save the original start linear predictor
69		const AVector linPredStart;
70
71		// pointer to an IWLS object
72		Iwls * iwlsObject;
73
74		// pointer to a Coxfit object
75		Coxfit * coxfitObject;
76
77		// number of IWLS iterations
78		PosInt nIter;
79
80		// the size of the model
81		const int modSize;
82
83		// the residual deviance of the model (only filled with correct value if TBF approach is used)
84		double modResidualDeviance;
85		};
86
87
88		#endif /* ZDENSITY_H_ */

1		/*
2		* fpUcHandling.cpp
3		*
4		* Created on: 09.11.2009
5		* Author: daniel
6		*
7		* 13/07/2015 Replace assert() with Rccp:Stop()
8		*/
9
10		#include "fpUcHandling.h"
11
12		//#include <cassert>
13		#include <algorithm>
14
15		#include "rcppExport.h"
16
17		// ***************************************************************************************************//
18
19		// small helper function to structure code:
20		// get the maximum power set for a range of FP maximum degrees
21		MyDoubleVector
22	1368x	getMaxPowerSet(const PosIntVector& fpmaxs)
23		{
24		// always in the power set:
25		static const double fixedpowers[] = { -2, -1, -0.5, 0, 0.5, 1, 2, 3 };
26		// corresponding indices 0 1 2 3 4 5 6 7
27
28		// convert to double vector
29	1368x	MyDoubleVector maxPowerset(fixedpowers, fixedpowers + 8);
30
31	1368x	if (! fpmaxs.empty())
32		{
33		// consider if the power set is even bigger
34	240x	const PosInt biggestMaxDegree = * std::max_element(fpmaxs.begin(),
35	240x	fpmaxs.end());
36		for (PosInt more = 4; more <= biggestMaxDegree; ++more)
37		{
38	!	maxPowerset.push_back(more);
39		}
40		}
41
42		// return the maximum power "set"
43	2736x	return (maxPowerset);
44		}
45
46
47		// ***************************************************************************************************//
48
49		// fpInfo //
50
51		MyDoubleVector
52	9600x	FpInfo::inds2powers(const Powers& m) const // convert inds m (a "Powers" object) into powers vector p (a MyDoubleVector)
53		{
54	9600x	MyDoubleVector ret;
55
56	9600x	for (Powers::const_iterator j = m.begin();
57	14808x	j != m.end();
58	5208x	j++)
59		{
60	5208x	ret.push_back(powerset[*j]);
61		}
62
63	9600x	return ret;
64		}
65
66
67		// convert std::vector of powers into Powers object (i.e. a multiset) of ints of the power indexes.
68		Powers
69	264x	FpInfo::vec2inds(const MyDoubleVector& p) const
70		{
71	264x	Powers ret;
72
73	264x	for(MyDoubleVector::const_iterator j = p.begin();
74	384x	j != p.end();
75	120x	j++)
76		{
77		// the index which we look for is the difference of the start of the powerset and the
78		// iterator pointing to the location where the power was found.
79	120x	int index = find(powerset.begin(), powerset.end(), *j) - powerset.begin();
80	120x	ret.insert(index);
81		}
82
83	264x	return ret;
84		}
85
86		// ***************************************************************************************************//
87
88
89		// Box-Tidwell transform
90		static inline double
91	2355456x	boxtidwell(double x, double power)
92		{
93	2355456x	return (power != 0) ? pow(x, power) : log(x);
94		}
95
96		// ***************************************************************************************************//
97
98		// build array of vectors of AVectors holding the required transformed values for the design matrices
99		// do not! center the column. This is done inside getFpMatrix, because the repeated powers case cannot
100		// be treated here!!
101		AVectorArray
102	684x	getTransformedCols(const PosIntVector& fpcards,
103		const PosIntVector& fppos,
104		const PosIntVector& fpmaxs,
105		const AMatrix& x)
106		{
107		// initialize the return value
108	684x	AVectorArray transformedCols;
109
110		// get maximum powerset
111	684x	MyDoubleVector maxPowerset = getMaxPowerSet(fpmaxs);
112
113		// process each FP term
114	684x	PosIntVector::const_iterator card = fpcards.begin();
115	1380x	for (PosIntVector::const_iterator pos = fppos.begin(); pos != fppos.end(); ++card, ++pos)
116		{
117		// the original column
118	1392x	const AVector thisCol = x.col(*pos - 1);
119
120		// start vector of columns for this FP term
121	696x	std::vector<AVector> thisFp;
122
123		// for every possible power
124	6264x	for (PosInt j = 0; j != *card; j++)
125		{
126		// start with original column
127	5568x	AVector thisTransform = thisCol;
128
129		// then transform it according to the power:
130	2361024x	for (PosInt k = 0; k < thisTransform.n_rows; ++k)
131		{
132		// assert(thisTransform(k) > 0);
133		if(!(thisTransform(k) > 0)) Rcpp::stop("fpUcHandling.cpp:getTransformedCols: thisTransform(k) not greater than 0");
134
135	7066368x	thisTransform(k) = boxtidwell(thisTransform(k),
136	2355456x	maxPowerset[j]);
137
138		// assert(! ISNAN(thisTransform(k)));
139		if(ISNAN(thisTransform(k))) Rcpp::stop("fpUcHandling.cpp:getTransformedCols: thisTransform(k) is NAN");
140		}
141
142		// and put it into vector of columns
143	5568x	thisFp.push_back(thisTransform);
144		}
145
146		// push vector of all powers for this FP term into the array
147	696x	transformedCols.push_back(thisFp);
148		}
149
150		// return the array
151	1368x	return (transformedCols);
152		}
153
154		// ***************************************************************************************************//
155
156
157		// convert frequency vector into multiset
158		Powers
159	!	freqvec2Powers(IntVector& vec, const int &vecLength)
160		{
161	!	Powers ret;
162	!	for (int power = 0; power != vecLength; power++)
163		{
164	!	for (int times = 0; times != vec[power]; times++)
165	!	ret.insert(power);
166		}
167	!	return ret;
168		}
169
170		// ***************************************************************************************************//
171
172		// End of file.

1		/*
2		* functionWraps.cpp
3		*
4		* Created on: 06.11.2009
5		* Author: daniel
6		*/
7
8		#include "functionWraps.h"
9		#include "rcppExport.h"
10
11		using namespace Rcpp;
12
13		// ***************************************************************************************************//
14
15		// first R functions taking only a scalar
16
17		//// constructor
18		//RFunction::RFunction(SEXP R_fun)
19		//{
20		// // allocate double scalar as function argument
21		// Rf_protect(R_functionArgument = Rf_allocVector(REALSXP, 1));
22		//
23		// // construct the function call
24		// Rf_protect(R_functionCall = Rf_lcons(R_fun,
25		// Rf_lcons(R_functionArgument,
26		// R_NilValue)));
27		//
28		// // get the function frame (is connected to the R function, so is already protected)
29		// R_functionFrame = FRAME(R_fun);
30		//}
31
32		//// copy constructor
33		//RFunction::RFunction(const RFunction& old)
34		//{
35		// // double scalar as function argument:
36		// // take the same one as the old object.
37		// Rf_protect(R_functionArgument = old.R_functionArgument);
38		//
39		// // so also for the function call we must take the same one
40		// Rf_protect(R_functionCall = old.R_functionCall);
41		//
42		// // and then finally get the function frame
43		// R_functionFrame = old.R_functionFrame;
44		//}
45
46
47		//// assignment operator
48		//RFunction& RFunction::operator=(const RFunction& rhs)
49		//{
50		// if(&rhs != this)
51		// {
52		// // first unprotect the current members
53		// Rf_unprotect(3);
54		//
55		// // then assign the new members:
56		//
57		// // double scalar as function argument:
58		// // take the same one as the old object.
59		// Rf_protect(R_functionArgument = rhs.R_functionArgument);
60		//
61		// // so also for the function call we must take the same one
62		// Rf_protect(R_functionCall = rhs.R_functionCall);
63		//
64		// // and then finally get the function frame
65		// R_functionFrame = rhs.R_functionFrame;
66		// }
67		//
68		// // return ourself
69		// return *this;
70		//}
71		//
72
73		//// destructor
74		//RFunction::~RFunction()
75		//{
76		// // unprotect the the function argument and the call
77		// Rf_unprotect(2);
78		//
79		// // everything else is automatically destroyed.
80		//}
81
82		// for use as a function
83		double
84	2694296x	RFunction::operator()(double x) const
85		{
86		// // input the argument
87		// REAL(R_functionArgument)[0] = x;
88
89		// // get the result
90		// SEXP R_pars;
91		// Rf_protect(R_pars = Rf_eval(R_functionCall,
92		// R_functionFrame));
93		//
94		// // now convert to double vector
95		// double ret = Rf_asReal(Rf_coerceVector(R_pars, REALSXP));
96		//
97		// // unprotect local R result
98		// Rf_unprotect(1);
99		//
100		// // and return that
101		// return ret;
102
103		// shorter:
104		// 8/11/2013: debug error
105		// "'rho' must be an environment not pairlist: detected in C-level eval"
106		// In gdb I find the following "classes" for the arguments:
107		// (see Rinternals.h, line 98 ff.)
108
109	2694296x	double ret = as<double>(fun(x));
110	2694296x	return ret;
111
112		// return Rf_asReal(Rf_coerceVector(Rf_eval(R_functionCall, // SEXP type 6: language constructs
113		// R_functionFrame), // SEXP type 2: lists of dotted pairs
114		// REALSXP));
115		}
116
117		// ***************************************************************************************************//
118
119
120		// now R functions taking a fixed length vector
121
122
123		//// constructor
124		//VectorRFunction::VectorRFunction(SEXP R_function, R_len_t argsize) :
125		// argsize(argsize)
126		//{
127		// // allocate vector as function argument
128		// Rf_protect(R_functionArgument = Rf_allocVector(REALSXP, argsize));
129		//
130		// // construct the function call
131		// Rf_protect(R_functionCall = Rf_lcons(R_function,
132		// Rf_lcons(R_functionArgument,
133		// R_NilValue)));
134		//
135		// // get the function frame (is connected to the R function, so is already protected)
136		// R_functionFrame = FRAME(R_function);
137		//}
138		//
139		//
140		//// destructor
141		//VectorRFunction::~VectorRFunction()
142		//{
143		// // unprotect the function argument and call
144		// Rf_unprotect(2);
145		//
146		// // everything else is automatically destroyed.
147		//}
148
149		// for use as a function
150		double
151	!	VectorRFunction::operator()(const double* vector) const
152		{
153		// copy the vector
154	!	NumericVector arg(argsize);
155	!	std::copy(vector, vector + argsize, arg.begin());
156
157		// and then evaluate the function call.
158	!	double ret = as<double>(fun(arg));
159	!	return ret;
160		}
161
162
163		// ***************************************************************************************************//
164
165		// save one pair of argument and function value
166		void
167	1916662x	Cache::save(double arg, double val)
168		{
169	1916662x	args.push_back(arg);
170	1916662x	vals.push_back(val);
171		}
172
173		// clear the cache
174		void
175	!	Cache::clear()
176		{
177	!	args.clear();
178	!	vals.clear();
179		}
180
181		// query for a function value
182		double
183	2958054x	Cache::getValue(double arg) const
184		{
185		// search for the argument
186	2958054x	MyDoubleVector::const_iterator iterVals = vals.begin();
187	2958054x	for(MyDoubleVector::const_iterator
188	2958054x	iterArgs = args.begin();
189	171884273x	iterArgs != args.end();
190	168926219x	++iterArgs, ++iterVals)
191		{
192		// match -> return corresponding value.
193	169967611x	if(*iterArgs == arg)
194		{
195	1041392x	return *iterVals;
196		}
197		}
198
199		// if we have not found the argument, return NA
200	1916662x	return R_NaReal;
201		}
202
203		// initialize from an R list
204	!	Cache::Cache(List& rcpp_list) :
205	!	args(as<MyDoubleVector>(rcpp_list["args"])),
206	!	vals(as<MyDoubleVector>(rcpp_list["vals"]))
207		{
208	!	if(args.size() != vals.size())
209		{
210	!	Rf_error("Lengths of args and vals vectors in R list converted to Cache object not equal!");
211		}
212		}
213
214		// convert to an Rcpp list
215		List
216	4719x	Cache::convert2list() const
217		{
218	9438x	return List::create(_["args"] = getArgs(),
219	14157x	_["vals"] = getVals());
220		}
221
222
223		// ***************************************************************************************************//
224
225		// End of file.

1		/*
2		* optimize.h
3		*
4		* Created on: 08.12.2009
5		* Author: daniel
6		*/
7
8		#ifndef OPTIMIZE_H_
9		#define OPTIMIZE_H_
10
11		#include "types.h"
12
13		// modified from R's scalar function "optimize" routine "Brent_fmin"
14		// in /src/appl/fmin.c,
15		// in order to take a functor instead of an ordinary function, and does not
16		// take an info argument
17
18		// original documentation:
19
20		// returns an approximation x to the point where f attains a minimum on
21		// the interval (ax,bx) is determined.
22		//
23		// INPUT..
24		//
25		// ax left endpoint of initial interval
26		// bx right endpoint of initial interval
27		// f function which evaluates f(x, info) for any x
28		// in the interval (ax,bx)
29		// tol desired length of the interval of uncertainty of the final
30		// result ( >= 0.)
31		//
32		// OUTPUT..
33		//
34		// fmin abcissa approximating the point where f attains a minimum
35		//
36		// The method used is a combination of golden section search and
37		// successive parabolic interpolation. convergence is never much slower
38		// than that for a Fibonacci search. If f has a continuous second
39		// derivative which is positive at the minimum (which is not at ax or
40		// bx), then convergence is superlinear, and usually of the order of
41		// about 1.324....
42		// The function f is never evaluated at two points closer together
43		// than eps*abs(fmin)+(tol/3), where eps is approximately the square
44		// root of the relative machine precision. if f is a unimodal
45		// function and the computed values of f are always unimodal when
46		// separated by at least eps*abs(x)+(tol/3), then fmin approximates
47		// the abcissa of the global minimum of f on the interval ax,bx with
48		// an error less than 3epsabs(fmin)+tol. if f is not unimodal,
49		// then fmin may approximate a local, but perhaps non-global, minimum to
50		// the same accuracy.
51		// This function subprogram is a slightly modified version of the
52		// Algol 60 procedure localmin given in Richard Brent, Algorithms for
53		// Minimization without Derivatives, Prentice-Hall, Inc. (1973).
54
55
56		template <class Fun>
57		class Brent {
58		public:
59		// setup the object
60		// - function is the function to be maximized in the interval (lowerBound, upperBound)
61		// - lowerBound: lower bound on the function argument
62		// - upperBound: upper bound on the function argument
63		// - precision: desired length of the interval of uncertainty of the final result ( > 0.0,
64		// default: fourth root of machine precision)
65	6865x	Brent(Fun& function,
66		double lowerBound,
67		double upperBound,
68		double precision=sqrt(EPS)) : // EPS is the square root of the machine precision
69	6865x	function(function), lowerBound(lowerBound),
70	6865x	upperBound(upperBound), precision(precision)
71		{
72		// check arguments
73		if (R_finite(lowerBound) == FALSE \|\| R_finite(upperBound) == FALSE)
74	!	Rf_error("Brent: bounds must be finite");
75
76	6865x	if (lowerBound >= upperBound)
77	!	Rf_error("Brent: lowerBound not smaller than upperBound");
78
79	6865x	if (precision <= 0.0)
80	!	Rf_error("Brent: precision not positive");
81		}
82
83		// minimize the function
84		double
85		minimize ();
86
87		private:
88		// the function we want to maximize
89		Fun& function;
90
91		// constraints on the function argument
92		const double lowerBound;
93		const double upperBound;
94
95		// settings
96		const double precision;
97		};
98
99		// the actual minimization function
100		template<class Fun>
101		double
102	6865x	Brent<Fun>::minimize()
103		{
104		/* c is the squared inverse of the golden ratio */
105	6865x	const double c = (3.0 - sqrt(5.0)) * 0.5;
106
107		/* Local variables */
108		double a, b, d, e, p, q, r, u, v, w, x;
109		double t2, fu, fv, fw, fx, xm, eps, tol1, tol3;
110
111		/* eps is approximately the square root of the relative machine precision. */
112	6865x	eps = DBL_EPSILON;
113	6865x	tol1 = eps + 1.0; /* the smallest 1.000... > 1 */
114	6865x	eps = sqrt(eps);
115
116	6865x	a = lowerBound;
117	6865x	b = upperBound;
118
119	6865x	v = a + c * (b - a);
120	6865x	w = v;
121	6865x	x = v;
122
123	6865x	d = 0.0; /* -Wall */
124	6865x	e = 0.0;
125	6865x	fx = function(x);
126	6865x	fv = fx;
127	6865x	fw = fx;
128	6865x	tol3 = precision / 3.0;
129
130		/* main loop starts here ----------------------------------- */
131
132		for (;;)
133		{
134	99405x	xm = (a + b) * 0.5;
135	99405x	tol1 = eps * fabs(x) + tol3;
136	99405x	t2 = tol1 * 2.0;
137
138		/* check stopping criterion */
139
140	99405x	if (fabs(x - xm) <= t2 - (b - a) * 0.5)
141	6865x	break;
142	92540x	p = 0.0;
143	92540x	q = 0.0;
144	92540x	r = 0.0;
145	92540x	if (fabs(e) > tol1)
146		{ /* fit parabola */
147
148	85655x	r = (x - w) * (fx - fv);
149	85655x	q = (x - v) * (fx - fw);
150	85655x	p = (x - v) * q - (x - w) * r;
151	85655x	q = (q - r) * 2.0;
152	85655x	if (q > 0.0)
153	32785x	p = - p;
154		else
155	52870x	q = - q;
156	85655x	r = e;
157	85655x	e = d;
158		}
159
160	92540x	if (fabs(p) >= fabs(q * 0.5 * r) \|\| p <= q * (a - x) \|\| p >= q * (b - x))
161		{ /* a golden-section step */
162
163	23175x	if (x < xm)
164	10640x	e = b - x;
165		else
166	12535x	e = a - x;
167	23175x	d = c * e;
168		}
169		else
170		{ /* a parabolic-interpolation step */
171
172	69365x	d = p / q;
173	69365x	u = x + d;
174
175		/* f must not be evaluated too close to ax or bx */
176
177	69365x	if (u - a < t2 \|\| b - u < t2)
178		{
179	6855x	d = tol1;
180	6855x	if (x >= xm)
181	4015x	d = - d;
182		}
183		}
184
185		/* f must not be evaluated too close to x */
186
187	92540x	if (fabs(d) >= tol1)
188	86620x	u = x + d;
189	5920x	else if (d > 0.)
190	3720x	u = x + tol1;
191		else
192	2200x	u = x - tol1;
193
194	92540x	fu = function(u);
195
196		/* update a, b, v, w, and x */
197
198	92540x	if (fu <= fx)
199		{
200	48045x	if (u < x)
201	28440x	b = x;
202		else
203	19605x	a = x;
204	48045x	v = w;
205	48045x	w = x;
206	48045x	x = u;
207	48045x	fv = fw;
208	48045x	fw = fx;
209	48045x	fx = fu;
210		}
211		else
212		{
213	44495x	if (u < x)
214	21370x	a = u;
215		else
216	23125x	b = u;
217	44495x	if (fu <= fw \|\| w == x)
218		{
219	33375x	v = w;
220	33375x	fv = fw;
221	33375x	w = u;
222	33375x	fw = fu;
223		}
224	11120x	else if (fu <= fv \|\| v == x \|\| v == w)
225		{
226	8590x	v = u;
227	8590x	fv = fu;
228		}
229		}
230		}
231		/* end of main loop */
232
233		// return the found minimum
234	6865x	return x;
235		}
236
237
238
239		#endif /* OPTIMIZE_H_ */

1		/*
2		* gpriors.cpp
3		*
4		* Created on: 22.11.2012
5		* Author: daniel
6		*/
7
8
9		#include "gpriors.h"
10
11
12		// compute M(a, b)
13		static double
14	!	incInvGammaLogNormConst(double a, double b)
15		{
16		double logNormConst;
17	!	if(b > 0)
18		{
19	!	logNormConst = a * log(b) - Rf_pgamma(b, a, 1.0, 1, 1) - Rf_lgammafn(a);
20		} else {
21	!	logNormConst = log(a);
22		}
23	!	return logNormConst;
24		}
25
26		// Log prior density
27		double
28	!	IncInvGammaGPrior::logDens(double g) const
29		{
30	!	return (- (a + 1.0) * log1p(g) - b / (g + 1.0) + incInvGammaLogNormConst(a, b));
31		}
32
33
34		// for this class we have a closed form for the log marginal likelihood
35		// resulting from the TBF approach
36		double
37	!	IncInvGammaGPrior::getTBFLogMargLik(double residualDeviance, int df) const
38		{
39	!	return (incInvGammaLogNormConst(a, b) -
40	!	incInvGammaLogNormConst(a + df / 2.0, b + residualDeviance / 2.0) +
41	!	residualDeviance / 2.0);
42		}

1		#include <R.h>
2		#include <Rinternals.h>
3		#include <stdlib.h> // for NULL
4		#include <R_ext/Rdynload.h>
5
6		/* FIXME:
7		Check these declarations against the C/Fortran source code.
8		*/
9
10		/* .Call calls */
11		extern SEXP _glmBfp_cpp_bfgs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
12		extern SEXP _glmBfp_cpp_coxfit(SEXP, SEXP, SEXP, SEXP, SEXP);
13		extern SEXP _glmBfp_cpp_evalZdensity(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
14		extern SEXP _glmBfp_cpp_glmBayesMfp(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
15		extern SEXP _glmBfp_cpp_optimize(SEXP, SEXP, SEXP, SEXP);
16		extern SEXP _glmBfp_cpp_sampleGlm(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
17		extern SEXP _glmBfp_predBMAcpp(SEXP, SEXP, SEXP);
18
19		static const R_CallMethodDef CallEntries[] = {
20		{"_glmBfp_cpp_bfgs", (DL_FUNC) &_glmBfp_cpp_bfgs, 6},
21		{"_glmBfp_cpp_coxfit", (DL_FUNC) &_glmBfp_cpp_coxfit, 5},
22		{"_glmBfp_cpp_evalZdensity", (DL_FUNC) &_glmBfp_cpp_evalZdensity, 7},
23		{"_glmBfp_cpp_glmBayesMfp", (DL_FUNC) &_glmBfp_cpp_glmBayesMfp, 7},
24		{"_glmBfp_cpp_optimize", (DL_FUNC) &_glmBfp_cpp_optimize, 4},
25		{"_glmBfp_cpp_sampleGlm", (DL_FUNC) &_glmBfp_cpp_sampleGlm, 9},
26		{"_glmBfp_predBMAcpp", (DL_FUNC) &_glmBfp_predBMAcpp, 3},
27		{NULL, NULL, 0}
28		};
29
30	32x	void R_init_glmBfp(DllInfo *dll)
31		{
32	32x	R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
33	32x	R_useDynamicSymbols(dll, FALSE);
34		}

1		// * 13/07/2015 Replace assert() with Rccp:Stop()
2
3
4		#include "iwls.h"
5		#include "types.h"
6		#include "rcppExport.h"
7		//#include <cassert>
8		#include "design.h"
9		#include <stdexcept>
10		#include <sstream>
11		#include "linalgInterface.h"
12
13		// criterion for comparison of two Column vectors of the same size
14		// max_j (abs(a_j - b_j) / abs(b_j) + 0.01)
15		// this is similar to the criterion used by R's glm routine on the deviance scale.
16		// However, we want to avoid the posterior scale because it would slow down the algorithm...
17		// (computing this criterion is easier than computing the likelihood * prior)
18		double
19	194418x	criterion(const AVector& a, const AVector& b)
20		{
21		// check lengths
22		//assert(a.n_elem == b.n_elem);
23		if(a.n_elem != b.n_elem) Rcpp::stop("iwls.cpp:criterion: a.n_elem != b.n_elem");
24
25		// this will be the returned value
26	194418x	double ret = 0.0;
27
28		// now iterate over the elements
29		#pragma omp parallel for
30		for (PosInt j = 0; j < a.n_elem; ++j)
31		{
32		double tmp = fabs(a(j) - b(j)) / (fabs(b(j)) + 0.01);
33
34		// note that the "critical" directive is vital here!!
35		// Otherwise two executions of the same code can lead to different answers.
36		#pragma omp critical
37		ret = (tmp > ret) ? tmp : ret; /* fmax(ret, tmp); */
38		}
39
40		// return the criterion value.
41	194418x	return ret;
42		}
43
44
45		// constructor: constructs the Iwls object for given model and data.
46	910x	Iwls::Iwls(const ModelPar &mod,
47		const DataValues& data,
48		const FpInfo& fpInfo,
49		const UcInfo& ucInfo,
50		const FixInfo& fixInfo,
51		const GlmModelConfig& config,
52		const AVector& linPredStart,
53		bool conditional,
54		double epsilon,
55		bool debug,
56	910x	bool tbf) :
57	910x	design(getDesignMatrix(mod, data, fpInfo, ucInfo, fixInfo)),
58	910x	nCoefs(design.n_cols),
59	910x	isNullModel(nCoefs == 1),
60	910x	useFixedZ(conditional),
61	910x	nObs(design.n_rows),
62		// not possible because this could be the null model: designWithoutIntercept(nObs, nCoefs - 1),
63	910x	response(data.response),
64	910x	config(config),
65	1820x	invSqrtDispersions(1.0 / arma::sqrt(config.dispersions)),
66	910x	unscaledPriorPrec(nCoefs, nCoefs),
67	910x	results(linPredStart, nCoefs),
68	910x	epsilon(epsilon),
69		// verbose(debug),
70	910x	tbf(tbf)
71		{
72		// only do additional computations if not the TBF methodology is used
73	910x	if(! tbf)
74		{
75	910x	if(! isNullModel)
76		{
77	910x	AMatrix scaledDesignWithoutInterceptCrossprod;
78
79	910x	if(!config.empiricalgPrior){
80		// Scaled design matrix without the intercept.
81		// This will be diag(dispersions)^(-1/2) * design[, -1]
82		// (attention with 0-based indexing of Armadillo objects!)
83	3640x	AMatrix scaledDesignWithoutIntercept = arma::diagmat(invSqrtDispersions) * design.cols(1, nCoefs - 1);
84
85		// then the log of the determinant of B'(dispersions)^(-1)B, which is part of the submatrix of R^-1
86		// (we know that B'(dispersions)^(-1)B is positive definite, so we do not need to check the sign of the determinant)
87	910x	scaledDesignWithoutInterceptCrossprod = arma::trans(scaledDesignWithoutIntercept) * scaledDesignWithoutIntercept;
88		}
89
90	910x	AMatrix infoMatrix;
91	910x	if(config.empiricalgPrior)
92		{
93	!	IwlsResults resultsFisher = results;
94
95	!	unscaledPriorPrec.zeros();
96	!	infoMatrix = getInformation(100,
97	!	nObs,
98	!	invSqrtDispersions,
99		resultsFisher,
100		config,
101		response,
102	!	design,
103		epsilon,
104	!	unscaledPriorPrec
105	!	); //an alternative to using the X'X covariance matrix
106
107	!	scaledDesignWithoutInterceptCrossprod = infoMatrix.submat(1, 1, nCoefs - 1, nCoefs - 1);
108
109		}
110
111		// input that (the main ingredient) into the unscaled R^-1
112		// but first be sure there are zeroes anywhere else:
113	910x	unscaledPriorPrec.zeros();
114
115	2730x	unscaledPriorPrec.submat(1, 1, nCoefs - 1, nCoefs - 1) = scaledDesignWithoutInterceptCrossprod / config.cfactor;
116
117		// Rcpp::Rcout << "Prior Prec:\n"<< unscaledPriorPrec << std::endl;
118
119		// if(config.empiricalgPrior) unscaledPriorPrec.submat(1, 1, nCoefs - 1, nCoefs - 1) = infoMatrix.submat(1, 1, nCoefs - 1, nCoefs - 1);
120
121
122		// now directly use the cholesky routine to avoid copying too much unnecessarily
123	910x	int info = potrf(false,
124		scaledDesignWithoutInterceptCrossprod);
125
126		// check that all went well
127	910x	if(info != 0)
128		{
129	!	std::ostringstream stream;
130	!	stream << "dpotrf(scaledDesignWithoutInterceptCrossprod) got error code " << info << "in Iwls constructor";
131	!	throw std::domain_error(stream.str().c_str());
132		}
133		// now scaledDesignWithoutInterceptCrossprod contains the cholesky factor!
134
135		// also do not copy the cholesky factor saved now in nonInterceptDesignCrossprod into an extra matrix,
136		// but use the Triangular view
137	910x	logScaledDesignWithoutInterceptCrossprodDeterminant =
138	1820x	2.0 * arma::as_scalar(arma::sum(arma::log(arma::diagvec(scaledDesignWithoutInterceptCrossprod))));
139		} else {
140		// this is the null model
141
142		// be sure that this is correct:
143	!	unscaledPriorPrec(0, 0) = 0.0;
144		}
145		}
146		}
147
148		// 03/07/2013: add offsets
149
150		// do the Iwls algorithm for a given covariance factor g and start linear predictor linPred,
151		// until convergence or until the maximum number of iterations is reached.
152		// so also only one iwls step can be performed with this function.
153		// Note that the linear predictor is the sum of X^T * beta and the vector of offsets.
154		// returns the number of iterations.
155		PosInt
156	106057x	Iwls::startWithLastLinPred(PosInt maxIter,
157		double g)
158		{
159		// initialize iteration counter and stopping criterion
160	106057x	PosInt iter = 0;
161	106057x	bool converged = false;
162
163		// do IWLS for at most 30 iterations and unfulfilled stopping criterion
164	406532x	while ((iter++ < maxIter) && (! converged))
165		{
166		// compute the pseudo-observations and corresponding sqrt(weights) from the linear predictor
167	300475x	AVector pseudoObs(nObs);
168	300475x	AVector sqrtWeights(invSqrtDispersions);
169
170		#pragma omp parallel for
171		for(PosInt i = 0; i < nObs; ++i)
172		{
173		double mu = config.link->linkinv(results.linPred(i));
174		double dmudEta = config.link->mu_eta(results.linPred(i));
175
176		pseudoObs(i) = results.linPred(i) - config.offsets(i) + (response(i) - mu) / dmudEta;
177		sqrtWeights(i) *= dmudEta / sqrt(config.distribution->variance(mu));
178		}
179
180		// calculate X'sqrt(W), which is needed twice
181	901425x	AMatrix XtsqrtW = arma::trans(design) * arma::diagmat(sqrtWeights);
182
183		// calculate the precision matrix Q by doing a rank update:
184		// if full Bayes is used, then:
185		// Q = tcrossprod(X'sqrt(W)) + 1/g * unscaledPriorPrec
186		// if TBF are used, then:
187		// Q = tcrossprod(X'sqrt(W))
188		double scaleFactor = tbf ? 0.0 : 1.0 / g;
189	300475x	results.qFactor = unscaledPriorPrec;
190	300475x	syrk(false,
191		false,
192		XtsqrtW,
193		scaleFactor,
194	300475x	results.qFactor);
195
196		// decompose into Cholesky factor, Q = LL':
197	600950x	int info = potrf(false,
198	300475x	results.qFactor);
199
200		// check that no error occured
201	300475x	if(info != 0)
202		{
203	!	std::ostringstream stream;
204	!	stream << "Cholesky factorization Q = LL' got error code " << info <<
205	!	" in IWLS iteration " << iter;
206	!	if(! tbf)
207		{
208	!	stream << " for z=" << ::log(g);
209		}
210	!	throw std::domain_error(stream.str().c_str());
211		}
212
213		// save the old coefficients vector
214	300475x	AVector coefs_old = results.coefs;
215
216		// the rhs of the equation Q * m = rhs or R'R * m = rhs
217	300475x	pseudoObs = arma::diagmat(sqrtWeights) * pseudoObs;
218	300475x	results.coefs = XtsqrtW * pseudoObs;
219		// note that we have some steps to go until the computation
220		// of results.coefs is finished!
221
222		// forward-backward solve LL' * v = rhs
223	600950x	info = potrs(false,
224	300475x	results.qFactor,
225		results.coefs);
226
227		// check that no error occured
228	300475x	if(info != 0)
229		{
230	!	std::ostringstream stream;
231	!	stream << "Forward-backward solve got error code " << info <<
232	!	" in IWLS iteration " << iter;
233	!	if(! tbf)
234		{
235	!	stream << " for z=" << ::log(g);
236		}
237	!	throw std::domain_error(stream.str().c_str());
238		}
239
240		// the new linear predictor is
241	901425x	results.linPred = design * results.coefs + config.offsets;
242
243		// compare on the coefficients scale, but not in the first iteration where
244		// it is not clear from where coefs_old came. Be safe and always
245		// decide for non-convergence in this case.
246	300475x	converged = (iter > 1) ? (criterion(coefs_old, results.coefs) < epsilon) : false;
247		}
248
249		// do not (!)
250		// warn if IWLS did not converge within the maximum number of iterations
251		// because the maximum number of iterations can be set by user of this function.
252
253		// compute log precision determinant
254	318171x	results.logPrecisionDeterminant = 2.0 * arma::as_scalar(arma::sum(arma::log(arma::diagvec(results.qFactor))));
255
256		// last but not least return the number of iterations
257	106057x	return iter;
258		}
259
260		// do the Iwls algorithm for a given covariance factor g and new start linear predictor
261		// linPredStart.
262		PosInt
263	15407x	Iwls::startWithNewLinPred(PosInt maxIter,
264		double g,
265		const AVector& linPredStart)
266		{
267		// copy start value into linear predictor of the iwls object
268	15407x	results.linPred = linPredStart;
269
270		// then run the iwls algorithm
271	15407x	return startWithLastLinPred(maxIter, g);
272		}
273
274		// 03/07/2013: add offsets
275
276		// do the Iwls algorithm for a given covariance factor g and new start coefficients vector
277		// coefsStart.
278		PosInt
279	14700x	Iwls::startWithNewCoefs(PosInt maxIter,
280		double g,
281		const AVector& coefsStart)
282		{
283		// start with new linpred deriving from the coefs
284	44100x	return startWithNewLinPred(maxIter, g, design * coefsStart + config.offsets);
285		}
286
287		// 03/07/2013: add offsets
288
289		// compute the log of the (unnormalized)
290		// posterior density for a given parameter consisting of the coefficients vector and z.
291		//
292		// Note that it is important to incorporate all model-depending constants here,
293		// because this function is also used in the Chib-Jeliazkov marginal likelihood estimation,
294		// comparing different models!!
295		//
296		// useFixedZ: is the log-covariance factor z fixed? Then the conditional posterior
297		// density of the coefficients vector is returned (so the prior of z is not included).
298		double
299	98007x	Iwls::computeLogUnPosteriorDens(const Parameter& sample) const
300		{
301		// compute the sample of the linear predictor:
302	294021x	AVector linPredSample = design * sample.coefs + config.offsets;
303
304		// compute the resulting mean vector from the linear predictor via the response function
305	98007x	AVector meansSample(linPredSample.n_elem);
306
307		#pragma omp parallel for
308		for(PosInt i = 0; i < meansSample.n_elem; ++i)
309		{
310		meansSample(i) = config.link->linkinv(linPredSample(i));
311		}
312
313		// start with the log likelihood of this coefficients, it is always included
314		// this part is included in both cases because it does not depend on
315		// the prior on the (non-intercept) effects:
316
317	196014x	double ret = config.distribution->loglik(meansSample.memptr());
318
319		// now it depends again on null model or not.
320
321	98007x	if(! isNullModel)
322		{
323		// map z sample on the original g scale
324	98007x	double g = exp(sample.z);
325
326		// calculate \|\|(dispersions)^(-1/2) * B * beta\|\|^2
327	490035x	AVector scaledBcoefsSample = arma::diagmat(invSqrtDispersions) * (linPredSample - sample.coefs(0));
328
329		// this avoids this multiplication of general matrices:
330		// "DEVector scaledBcoefsSample = scaledDesignWithoutIntercept * sample.coefs(_(2, nCoefs));"
331	98007x	double scaledBcoefsSampleNormSquared = arma::dot(scaledBcoefsSample, scaledBcoefsSample);
332
333		// now add the non-null model specific part, which comes from the prior on
334		// the coefficients
335	98007x	ret += 0.5 * (logScaledDesignWithoutInterceptCrossprodDeterminant -
336	98007x	scaledBcoefsSampleNormSquared / (g * config.cfactor) -
337	98007x	(nCoefs - 1.0) * (2.0 * M_LN_SQRT_2PI + sample.z + log(config.cfactor)));
338
339	98007x	if(! useFixedZ)
340		{
341		// and the log prior of this g
342	98007x	double logGPrior = config.gPrior->logDens(g);
343
344		// add the log prior of z
345	98007x	ret += logGPrior + sample.z;
346
347		// note that the sample.z has its origin in the density transformation from g to z.
348		// if the prior on g was discrete and not continuous, this part would not be included in general.
349		}
350		}
351
352		// return the correct value
353	98007x	return ret;
354		}
355
356		// compute the deviance of the current model, which in R is done by the glm.fit function
357		// This is required to compute the TBF.
358		// Note that this changes the Iwls object, because it iterates until convergence
359		// or until the maximum number of iterations has been reached.
360		double
361	!	Iwls::computeDeviance(PosInt maxIter)
362		{
363	!	PosInt iter = startWithLastLinPred(maxIter, R_PosInf);
364
365		// if IWLS did not converge within the maximum number of iterations,
366		// throw error which is then caught by getGlmVarLogMargLik later on
367	!	if(iter > maxIter)
368		{
369	!	std::ostringstream stream;
370	!	stream << "model could not be fitted within " << maxIter <<
371	!	" IWLS iterations. This could be a result of separability in logistic regression, e.g.";
372	!	throw std::domain_error(stream.str().c_str());
373		}
374
375		// compute the resulting mean vector from the linear predictor via the response function
376	!	AVector means(nObs);
377
378		#pragma omp parallel for
379		for(PosInt i = 0; i < nObs; ++i)
380		{
381		means(i) = config.link->linkinv(results.linPred(i));
382		}
383
384		// compute the log-likelihood
385	!	double logLik = config.distribution->loglik(means.memptr());
386
387		// return the deviance, which is just the scaled log-likelihood
388	!	double ret = - 2.0 * logLik;
389	!	return ret;
390		}
391
392
393		// Compute a standard GLM to get the observed Fisher Information to use as covariance matrix.
394		AMatrix
395	!	Iwls::getInformation(PosInt maxIter, PosInt nObs, AVector invSqrtDispersions, IwlsResults results,
396		const GlmModelConfig& config, const AVector& response, const AMatrix design,
397		double epsilon, AMatrix unscaledPriorPrec)
398		{
399
400		// initialize iteration counter and stopping criterion
401	!	PosInt iter = 0;
402	!	bool converged = false;
403
404	!	AVector finalWeights(invSqrtDispersions);
405
406		// do IWLS for at most 30 iterations and unfulfilled stopping criterion
407	!	while ((iter++ < maxIter) && (! converged))
408		{
409		// compute the pseudo-observations and corresponding sqrt(weights) from the linear predictor
410	!	AVector pseudoObs(nObs);
411	!	AVector sqrtWeights(invSqrtDispersions);
412
413		#pragma omp parallel for
414		for(PosInt i = 0; i < nObs; ++i)
415		{
416		double mu = config.link->linkinv(results.linPred(i));
417		double dmudEta = config.link->mu_eta(results.linPred(i));
418
419		pseudoObs(i) = results.linPred(i) - config.offsets(i) + (response(i) - mu) / dmudEta;
420		sqrtWeights(i) *= dmudEta / sqrt(config.distribution->variance(mu));
421		}
422
423		// calculate X'sqrt(W), which is needed twice
424	!	AMatrix XtsqrtW = arma::trans(design) * arma::diagmat(sqrtWeights);
425
426		// calculate the precision matrix Q by doing a rank update:
427		// if full Bayes is used, then:
428		// Q = tcrossprod(X'sqrt(W)) + 1/g * unscaledPriorPrec
429		// if TBF are used, then:
430		// Q = tcrossprod(X'sqrt(W))
431	!	double scaleFactor = 0.0;
432	!	results.qFactor = unscaledPriorPrec; //just zeros to set up matrix
433	!	syrk(false,
434		false,
435		XtsqrtW,
436		scaleFactor,
437	!	results.qFactor);
438
439		// decompose into Cholesky factor, Q = LL':
440	!	int info = potrf(false,
441	!	results.qFactor);
442
443		// check that no error occured
444	!	if(info != 0)
445		{
446	!	std::ostringstream stream;
447	!	stream << "Cholesky factorization Q = LL' got error code " << info <<
448	!	" in IWLS iteration " << iter;
449
450	!	throw std::domain_error(stream.str().c_str());
451		}
452
453		// save the old coefficients vector
454	!	AVector coefs_old = results.coefs;
455
456		// the rhs of the equation Q * m = rhs or R'R * m = rhs
457	!	pseudoObs = arma::diagmat(sqrtWeights) * pseudoObs;
458	!	results.coefs = XtsqrtW * pseudoObs;
459
460		// note that we have some steps to go until the computation
461		// of results.coefs is finished!
462
463		// forward-backward solve LL' * v = rhs
464	!	info = potrs(false,
465	!	results.qFactor,
466		results.coefs);
467
468		// check that no error occured
469	!	if(info != 0)
470		{
471	!	std::ostringstream stream;
472	!	stream << "Forward-backward solve got error code " << info <<
473	!	" in IWLS iteration " << iter;
474
475	!	throw std::domain_error(stream.str().c_str());
476		}
477
478		// the new linear predictor is
479	!	results.linPred = design * results.coefs + config.offsets;
480
481		// compare on the coefficients scale, but not in the first iteration where
482		// it is not clear from where coefs_old came. Be safe and always
483		// decide for non-convergence in this case.
484	!	converged = (iter > 1) ? (criterion(coefs_old, results.coefs) < epsilon) : false;
485	!	finalWeights = sqrtWeights;
486		}
487
488		// do not (!)
489		// warn if IWLS did not converge within the maximum number of iterations
490		// because the maximum number of iterations can be set by user of this function.
491
492		// compute log precision determinant
493	!	results.logPrecisionDeterminant = 2.0 * arma::as_scalar(arma::sum(arma::log(arma::diagvec(results.qFactor))));
494
495
496		//to calculate the observed Information we need the dispersion
497		double dispersion;
498	!	if( config.familyString == "poisson" \|\| config.familyString == "binomial" ){
499	!	dispersion = 1;
500		} else {
501	!	dispersion = dot(finalWeights, arma::square(response - results.linPred))/(nObs-results.coefs.n_elem);
502		}
503
504
505	!	AMatrix observed = arma::trans(design) * arma::diagmat(arma::square(finalWeights)) * design / dispersion;
506
507
508	!	AVector residuals = arma::square(response - results.linPred);
509
510	!	return(observed);
511		}